diff --git a/thys/Complex_Bounded_Operators/Cblinfun_Code.thy b/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
--- a/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
+++ b/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
@@ -1,659 +1,661 @@
 section \<open>\<open>Cblinfun_Code\<close> -- Support for code generation\<close>
 
 text \<open>This theory provides support for code generation involving on complex vector spaces and
   bounded operators (e.g., types \<open>cblinfun\<close> and \<open>ell2\<close>).
   To fully support code generation, in addition to importing this theory,
   one need to activate support for code generation (import theory \<open>Jordan_Normal_Form.Matrix_Impl\<close>)
   and for real and complex numbers (import theory \<open>Real_Impl.Real_Impl\<close> for support of reals of the 
   form \<open>a + b * sqrt c\<close> or \<open>Algebraic_Numbers.Real_Factorization\<close> (much slower) for support of algebraic reals;
   support of complex numbers comes "for free").
 
   The builtin support for real and complex numbers (in \<open>Complex_Main\<close>) is not sufficient because it
   does not support the computation of square-roots which are used in the setup below.
 
   It is also recommended to import \<open>HOL-Library.Code_Target_Numeral\<close> for faster support of nats 
   and integers.\<close>
 
 theory Cblinfun_Code
   imports
     Cblinfun_Matrix Containers.Set_Impl Jordan_Normal_Form.Matrix_Kernel
 begin
 
 no_notation "Lattice.meet" (infixl "\<sqinter>\<index>" 70)
 no_notation "Lattice.join" (infixl "\<squnion>\<index>" 65)
 hide_const (open) Coset.kernel
 hide_const (open) Matrix_Kernel.kernel
 hide_const (open) Order.bottom Order.top
 
+unbundle lattice_syntax
 unbundle jnf_notation
 unbundle cblinfun_notation
 
 
 
 subsection \<open>Code equations for cblinfun operators\<close>
 
 text \<open>In this subsection, we define the code for all operations involving only 
   operators (no combinations of operators/vectors/subspaces)\<close>
 
 
 text \<open>The following lemma registers cblinfun as an abstract datatype with 
   constructor \<^const>\<open>cblinfun_of_mat\<close>.
   That means that in generated code, all cblinfun operators will be represented
   as \<^term>\<open>cblinfun_of_mat X\<close> where X is a matrix.
   In code equations for operations involving operators (e.g., +), we
   can then write the equation directly in terms of matrices
   by writing, e.g., \<^term>\<open>mat_of_cblinfun (A+B)\<close> in the lhs,
   and in the rhs we define the matrix that corresponds to the sum of A,B.
   In the rhs, we can access the matrices corresponding to A,B by
   writing \<^term>\<open>mat_of_cblinfun B\<close>.
   (See, e.g., lemma \<open>cblinfun_of_mat_plusOp\<close> below).
 
   See @{cite "code-generation-tutorial"} for more information on 
   @{theory_text \<open>[code abstype]\<close>}.\<close>
 
 declare mat_of_cblinfun_inverse [code abstype]
 
 
 text \<open>This lemma defines addition. By writing \<^term>\<open>mat_of_cblinfun (M + N)\<close>
 on the left hand side, we get access to the\<close>
 
 
 declare mat_of_cblinfun_plus[code]
   \<comment> \<open>Code equation for addition of cblinfuns\<close>
 
 declare mat_of_cblinfun_id[code]
   \<comment> \<open>Code equation for computing the identity operator\<close>
 
 declare mat_of_cblinfun_1[code]
   \<comment> \<open>Code equation for computing the one-dimensional identity\<close>
 
 declare mat_of_cblinfun_zero[code]
   \<comment> \<open>Code equation for computing the zero operator\<close>
 
 
 declare mat_of_cblinfun_uminus[code]
   \<comment> \<open>Code equation for computing the unary minus on cblinfun's\<close>
 
 
 declare mat_of_cblinfun_minus[code]
   \<comment> \<open>Code equation for computing the difference of cblinfun's\<close>
 
 
 declare mat_of_cblinfun_classical_operator[code]
   \<comment> \<open>Code equation for computing the "classical operator"\<close>
 
 declare mat_of_cblinfun_compose[code]
   \<comment> \<open>Code equation for computing the composition/product of cblinfun's\<close>
 
 declare mat_of_cblinfun_scaleC[code]
   \<comment> \<open>Code equation for multiplication with complex scalar\<close>
 
 declare mat_of_cblinfun_scaleR[code]
   \<comment> \<open>Code equation for multiplication with real scalar\<close>
 
 declare mat_of_cblinfun_adj[code]
   \<comment> \<open>Code equation for computing the adj\<close>
 
 text \<open>This instantiation defines a code equation for equality tests for cblinfun.\<close>
 instantiation cblinfun :: (onb_enum,onb_enum) equal begin
 definition [code]: "equal_cblinfun M N \<longleftrightarrow> mat_of_cblinfun M = mat_of_cblinfun N" 
   for M N :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
 instance 
   apply intro_classes
   unfolding equal_cblinfun_def 
   using mat_of_cblinfun_inj injD by fastforce
 end
 
 subsection \<open>Vectors\<close>
 
 text \<open>In this section, we define code for operations on vectors. As with operators above,
   we do this by using an isomorphism between finite vectors
   (i.e., types T of sort \<open>complex_vector\<close>) and the type \<^typ>\<open>complex vec\<close> from
   \<^session>\<open>Jordan_Normal_Form\<close>. We have developed such an isomorphism in 
   theory \<open>Cblinfun_Matrix\<close> for 
   any type T of sort \<open>onb_enum\<close> (i.e., any type with a finite canonical orthonormal basis)
   as was done above for bounded operators.
   Unfortunately, we cannot declare code equations for a type class, 
   code equations must be related to a specific type constructor.
   So we give code definition only for vectors of type \<^typ>\<open>'a ell2\<close> (where \<^typ>\<open>'a\<close>
   must be of sort \<open>enum\<close> to make make sure that \<^typ>\<open>'a ell2\<close> is finite dimensional).
   
   The isomorphism between \<^typ>\<open>'a ell2\<close> is given by the constants \<open>ell2_of_vec\<close>
   and \<open>vec_of_ell2\<close> which are copies of the more general \<^const>\<open>basis_enum_of_vec\<close>
   and \<^const>\<open>vec_of_basis_enum\<close> but with a more restricted type to be usable in our code equations.
 \<close>
 
 definition ell2_of_vec :: "complex vec \<Rightarrow> 'a::enum ell2" where "ell2_of_vec = basis_enum_of_vec"
 definition vec_of_ell2 :: "'a::enum ell2 \<Rightarrow> complex vec" where "vec_of_ell2 = vec_of_basis_enum"
 
 text \<open>The following theorem registers the isomorphism \<open>ell2_of_vec\<close>/\<open>vec_of_ell2\<close>
   for code generation. From now on,
   code for operations on \<^typ>\<open>_ ell2\<close> can be expressed by declarations such
   as \<^term>\<open>vec_of_ell2 (f a b) = g (vec_of_ell2 a) (vec_of_ell2 b)\<close>
   if the operation f on \<^typ>\<open>_ ell2\<close> corresponds to the operation g on
   \<^typ>\<open>complex vec\<close>.\<close>
 
 lemma vec_of_ell2_inverse [code abstype]:
   "ell2_of_vec (vec_of_ell2 B) = B" 
   unfolding ell2_of_vec_def vec_of_ell2_def
   by (rule vec_of_basis_enum_inverse)
 
 text \<open>This instantiation defines a code equation for equality tests for ell2.\<close>
 instantiation ell2 :: (enum) equal begin
 definition [code]: "equal_ell2 M N \<longleftrightarrow> vec_of_ell2 M = vec_of_ell2 N" 
   for M N :: "'a::enum ell2"
 instance 
   apply intro_classes
   unfolding equal_ell2_def
   by (metis vec_of_ell2_inverse)
 end
 
 lemma vec_of_ell2_zero[code]:
   \<comment> \<open>Code equation for computing the zero vector\<close>
   "vec_of_ell2 (0::'a::enum ell2) = zero_vec (CARD('a))"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_zero)
 
 lemma vec_of_ell2_ket[code]:
   \<comment> \<open>Code equation for computing a standard basis vector\<close>
   "vec_of_ell2 (ket i) = unit_vec (CARD('a)) (enum_idx i)" 
   for i::"'a::enum"
   using vec_of_ell2_def vec_of_basis_enum_ket by metis
 
 lemma vec_of_ell2_timesScalarVec[code]: 
   \<comment> \<open>Code equation for multiplying a vector with a complex scalar\<close>
   "vec_of_ell2 (scaleC a \<psi>) = smult_vec a (vec_of_ell2 \<psi>)"
   for \<psi> :: "'a::enum ell2"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleC)
 
 lemma vec_of_ell2_scaleR[code]: 
   \<comment> \<open>Code equation for multiplying a vector with a real scalar\<close>
   "vec_of_ell2 (scaleR a \<psi>) = smult_vec (complex_of_real a) (vec_of_ell2 \<psi>)"
   for \<psi> :: "'a::enum ell2"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleR)
 
 lemma ell2_of_vec_plus[code]:
   \<comment> \<open>Code equation for adding vectors\<close>
   "vec_of_ell2 (x + y) =  (vec_of_ell2 x) + (vec_of_ell2 y)" for x y :: "'a::enum ell2"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_add) 
 
 lemma ell2_of_vec_minus[code]:
   \<comment> \<open>Code equation for subtracting vectors\<close>
   "vec_of_ell2 (x - y) =  (vec_of_ell2 x) - (vec_of_ell2 y)" for x y :: "'a::enum ell2"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_minus)
 
 lemma ell2_of_vec_uminus[code]:
   \<comment> \<open>Code equation for negating a vector\<close>
   "vec_of_ell2 (- y) =  - (vec_of_ell2 y)" for y :: "'a::enum ell2"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_uminus)
 
 lemma cinner_ell2_code' [code]: "cinner \<psi> \<phi> = cscalar_prod (vec_of_ell2 \<phi>) (vec_of_ell2 \<psi>)"
   \<comment> \<open>Code equation for the inner product of vectors\<close>
   by (simp add: cscalar_prod_vec_of_basis_enum vec_of_ell2_def)
 
 lemma norm_ell2_code [code]: 
   \<comment> \<open>Code equation for the norm of a vector\<close>
   "norm \<psi> = (let \<psi>' = vec_of_ell2 \<psi> in
     sqrt (\<Sum> i \<in> {0 ..< dim_vec \<psi>'}. let z = vec_index \<psi>' i in (Re z)\<^sup>2 + (Im z)\<^sup>2))"
   by (simp add: norm_ell2_vec_of_basis_enum vec_of_ell2_def)
 
 lemma times_ell2_code'[code]: 
   \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
   fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
   shows "vec_of_ell2 (\<psi> * \<phi>)
    = vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 * vec_index (vec_of_ell2 \<phi>) 0]"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_times)
 
 lemma divide_ell2_code'[code]: 
   \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
   fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
   shows "vec_of_ell2 (\<psi> / \<phi>)
    = vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 / vec_index (vec_of_ell2 \<phi>) 0]"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_divide)
 
 lemma inverse_ell2_code'[code]: 
   \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
   fixes \<psi> :: "'a::{CARD_1,enum} ell2"
   shows "vec_of_ell2 (inverse \<psi>)
    = vec_of_list [inverse (vec_index (vec_of_ell2 \<psi>) 0)]"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_to_inverse)
 
 lemma one_ell2_code'[code]: 
   \<comment> \<open>Code equation for the unit in the algebra of one-dimensional vectors\<close>
   "vec_of_ell2 (1 :: 'a::{CARD_1,enum} ell2) = vec_of_list [1]"
   by (simp add: vec_of_ell2_def vec_of_basis_enum_1) 
 
 subsection \<open>Vector/Matrix\<close>
 
 text \<open>We proceed to give code equations for operations involving both
   operators (cblinfun) and vectors. As explained above, we have to restrict
   the equations to vectors of type \<^typ>\<open>'a ell2\<close> even though the theory is available
   for any type of class \<^class>\<open>onb_enum\<close>. As a consequence, we run into an
   addition technicality now. For example, to define a code equation for applying
   an operator to a vector, we might try to give the following lemma:
 
 \<^theory_text>\<open>lemma cblinfun_apply_code[code]:
   "vec_of_ell2 (M *\<^sub>V x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
   by (simp add: mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)\<close>
 
   Unfortunately, this does not work, Isabelle produces the warning 
   "Projection as head in equation", most likely due to the fact that
   the type of \<^term>\<open>(*\<^sub>V)\<close> in the equation is less general than the type of 
   \<^term>\<open>(*\<^sub>V)\<close> (it is restricted to @{type ell2}). We overcome this problem
   by defining a constant \<open>cblinfun_apply_code\<close> which is equal to \<^term>\<open>(*\<^sub>V)\<close>
   but has a more restricted type. We then instruct the code generation 
   to replace occurrences of \<^term>\<open>(*\<^sub>V)\<close> by \<open>cblinfun_apply_code\<close> (where possible),
   and we add code generation for \<open>cblinfun_apply_code\<close> instead of \<^term>\<open>(*\<^sub>V)\<close>.
 \<close>
 
 
 definition cblinfun_apply_code :: "'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'b ell2" 
   where [code del, code_abbrev]: "cblinfun_apply_code = (*\<^sub>V)"
     \<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
      rhs \<^term>\<open>(*\<^sub>V)\<close> by the lhs \<^term>\<open>cblinfun_apply_code\<close> before starting 
      the actual code generation.\<close>
 
 lemma cblinfun_apply_code[code]:
   \<comment> \<open>Code equation for \<^term>\<open>cblinfun_apply_code\<close>, i.e., for applying an operator
      to an \<^type>\<open>ell2\<close> vector\<close>
   "vec_of_ell2 (cblinfun_apply_code M x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
   by (simp add: cblinfun_apply_code_def mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)
 
 text \<open>For the constant \<^term>\<open>vector_to_cblinfun\<close> (canonical isomorphism from
   vectors to operators), we have the same problem and define a constant
   \<open>vector_to_cblinfun_code\<close> with more restricted type\<close>
 
 definition vector_to_cblinfun_code :: "'a ell2 \<Rightarrow> 'b::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a ell2" where
   [code del,code_abbrev]: "vector_to_cblinfun_code = vector_to_cblinfun"
   \<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
      rhs \<^term>\<open>vector_to_cblinfun\<close> by the lhs \<^term>\<open>vector_to_cblinfun_code\<close>
      before starting the actual code generation.\<close>
 
 lemma vector_to_cblinfun_code[code]: 
   \<comment> \<open>Code equation for translating a vector into an operation (single-column matrix)\<close>
   "mat_of_cblinfun (vector_to_cblinfun_code \<psi>) = mat_of_cols (CARD('a)) [vec_of_ell2 \<psi>]"
   for \<psi>::"'a::enum ell2"
   by (simp add: mat_of_cblinfun_vector_to_cblinfun  vec_of_ell2_def vector_to_cblinfun_code_def)
 
 subsection \<open>Subspaces\<close>
 
 text \<open>In this section, we define code equations for handling subspaces, i.e.,
 values of type \<^typ>\<open>'a ccsubspace\<close>. We choose to computationally represent
 a subspace by a list of vectors that span the subspace. That is,
 if \<^term>\<open>vecs\<close> are vectors (type \<^typ>\<open>complex vec\<close>), \<open>SPAN vecs\<close> is defined to be their
 span. Then the code generation can simply represent all subspaces in this form, and 
 we need to define the operations on subspaces in terms of list of vectors 
 (e.g., the closed union of two subspaces would be computed as the concatenation 
 of the two lists, to give one of the simplest examples).
 
 To support this, \<open>SPAN\<close> is declared as a "\<open>code_datatype\<close>".
 (Not as an abstract datatype like \<^term>\<open>cblinfun_of_mat\<close>/\<^term>\<open>mat_of_cblinfun\<close>
 because that would require \<open>SPAN\<close> to be injective.)
 
 Then all code equations for different operations need to be formulated as
 functions of values of the form \<open>SPAN x\<close>. (E.g., \<open>SPAN x + SPAN y = SPAN (\<dots>)\<close>.)\<close>
 
 definition [code del]: "SPAN x = (let n = length (canonical_basis :: 'a::onb_enum list) in
     ccspan (basis_enum_of_vec ` Set.filter (\<lambda>v. dim_vec v = n) (set x)) :: 'a ccsubspace)"
   \<comment> \<open>The SPAN of vectors x, as a \<^type>\<open>ccsubspace\<close>.
       We filter out vectors of the wrong dimension because \<open>SPAN\<close> needs to have
       well-defined behavior even in cases that would not actually occur in an execution.\<close>
 code_datatype SPAN
 
 text \<open>We first declare code equations for \<^term>\<open>Proj\<close>, i.e., for
 turning a subspace into a projector. This means, we would need a code equation
 of the form \<open>mat_of_cblinfun (Proj (SPAN S)) = \<dots>\<close>. However, this equation is
 not accepted by the code generation for reasons we do not understand. But
 if we define an auxiliary constant \<open>mat_of_cblinfun_Proj_code\<close> that stands for 
 \<open>mat_of_cblinfun (Proj _)\<close>, define a code equation for \<open>mat_of_cblinfun_Proj_code\<close>,
 and then define a code equation for \<open>mat_of_cblinfun (Proj S)\<close> in terms of 
 \<open>mat_of_cblinfun_Proj_code\<close>, Isabelle accepts the code equations.\<close>
 
 definition "mat_of_cblinfun_Proj_code S = mat_of_cblinfun (Proj S)"
 declare mat_of_cblinfun_Proj_code_def[symmetric, code]
 
 lemma mat_of_cblinfun_Proj_code_code[code]: 
   \<comment> \<open>Code equation for computing a projector onto a set S of vectors.
      We first make the vectors S into an orthonormal basis using
      the Gram-Schmidt procedure and then compute the projector
      as the sum of the "butterflies" \<open>x * x*\<close> of the vectors \<open>x\<in>S\<close>
      (done by \<^term>\<open>mk_projector_orthog\<close>).\<close>
   "mat_of_cblinfun_Proj_code (SPAN S :: 'a::onb_enum ccsubspace) = 
     (let d = length (canonical_basis :: 'a list) in mk_projector_orthog d 
               (gram_schmidt0 d (filter (\<lambda>v. dim_vec v = d) S)))"
 proof -
   have *: "map_option vec_of_basis_enum (if dim_vec x = length (canonical_basis :: 'a list) then Some (basis_enum_of_vec x :: 'a) else None)
       = (if dim_vec x = length (canonical_basis :: 'a list) then Some x else None)" for x
     by auto
   show ?thesis
     unfolding SPAN_def mat_of_cblinfun_Proj_code_def
     using mat_of_cblinfun_Proj_ccspan[where S = 
         "map basis_enum_of_vec (filter (\<lambda>v. dim_vec v = (length (canonical_basis :: 'a list))) S) :: 'a list"]
     apply (simp only: Let_def map_filter_map_filter filter_set image_set map_map_filter o_def)
     unfolding *
     by (simp add: map_filter_map_filter[symmetric])
 qed
 
 lemma top_ccsubspace_code[code]: 
   \<comment> \<open>Code equation for \<^term>\<open>top\<close>, the subspace containing everything.
       Top is represented as the span of the standard basis vectors.\<close>
   "(top::'a ccsubspace) =
       (let n = length (canonical_basis :: 'a::onb_enum list) in SPAN (unit_vecs n))"
   unfolding SPAN_def
   apply (simp only: index_unit_vec Let_def map_filter_map_filter filter_set image_set map_map_filter 
       map_filter_map o_def unit_vecs_def)
   apply (simp add: basis_enum_of_vec_unit_vec)
   apply (subst nth_image)
   by (auto simp: )
 
 lemma bot_as_span[code]: 
   \<comment> \<open>Code equation for \<^term>\<open>bot\<close>, the subspace containing everything.
       Top is represented as the span of the standard basis vectors.\<close>
   "(bot::'a::onb_enum ccsubspace) = SPAN []"
   unfolding SPAN_def by (auto simp: Set.filter_def)
 
 
 lemma sup_spans[code]:
   \<comment> \<open>Code equation for the join (lub) of two subspaces (union of the generating lists)\<close>
   "SPAN A \<squnion> SPAN B = SPAN (A @ B)"
   unfolding SPAN_def 
   by (auto simp: ccspan_union image_Un filter_Un Let_def)
 
 text \<open>We do not need an equation for \<^term>\<open>(+)\<close> because \<^term>\<open>(+)\<close>
 is defined in terms of \<^term>\<open>(\<squnion>)\<close> (for \<^type>\<open>ccsubspace\<close>), thus the code generation automatically
 computes \<^term>\<open>(+)\<close> in terms of the code for \<^term>\<open>(\<squnion>)\<close>\<close>
 
 definition [code del,code_abbrev]: "Span_code (S::'a::enum ell2 set) = (ccspan S)"
   \<comment> \<open>A copy of \<^term>\<open>ccspan\<close> with restricted type. For analogous reasons as
      \<^term>\<open>cblinfun_apply_code\<close>, see there for explanations\<close>
 
 lemma span_Set_Monad[code]: "Span_code (Set_Monad l) = (SPAN (map vec_of_ell2 l))"
   \<comment> \<open>Code equation for the span of a finite set. (\<^term>\<open>Set_Monad\<close> is a datatype
      constructor that represents sets as lists in the computation.)\<close>
   apply (simp add: Span_code_def SPAN_def Let_def)
   apply (subst Set_filter_unchanged)
    apply (auto simp add: vec_of_ell2_def)[1]
   by (metis (no_types, lifting) ell2_of_vec_def image_image map_idI set_map vec_of_ell2_inverse)
 
 text \<open>This instantiation defines a code equation for equality tests for \<^type>\<open>ccsubspace\<close>.
       The actual code for equality tests is given below (lemma \<open>equal_ccsubspace_code\<close>).\<close>
 instantiation ccsubspace :: (onb_enum) equal begin
 definition [code del]: "equal_ccsubspace (A::'a ccsubspace) B = (A=B)"
 instance apply intro_classes unfolding equal_ccsubspace_def by simp
 end
 
 lemma leq_ccsubspace_code[code]:
   \<comment> \<open>Code equation for deciding inclusion of one space in another.
      Uses the constant \<^term>\<open>is_subspace_of_vec_list\<close> which implements the actual
      computation by checking for each generator of A whether it is in the
      span of B (by orthogonal projection onto an orthonormal basis of B
      which is computed using Gram-Schmidt).\<close>
   "SPAN A \<le> (SPAN B :: 'a::onb_enum ccsubspace)
       \<longleftrightarrow> (let d = length (canonical_basis :: 'a list) in
           is_subspace_of_vec_list d
           (filter (\<lambda>v. dim_vec v = d) A)
           (filter (\<lambda>v. dim_vec v = d) B))"
 proof -
   define d A' B' where "d = length (canonical_basis :: 'a list)"
     and "A' = filter (\<lambda>v. dim_vec v = d) A"
     and "B' = filter (\<lambda>v. dim_vec v = d) B"
 
   show ?thesis
     unfolding SPAN_def d_def[symmetric] filter_set Let_def
       A'_def[symmetric] B'_def[symmetric] image_set
     apply (subst ccspan_leq_using_vec)
     unfolding d_def[symmetric] map_map o_def
     apply (subst map_cong[where xs=A', OF refl])
      apply (rule basis_enum_of_vec_inverse)
      apply (simp add: A'_def d_def)
     apply (subst map_cong[where xs=B', OF refl])
      apply (rule basis_enum_of_vec_inverse)
     by (simp_all add: B'_def d_def)
 qed
 
 lemma equal_ccsubspace_code[code]:
   \<comment> \<open>Code equation for equality test. By checking mutual inclusion
       (for which we have code by the preceding code equation).\<close>
   "HOL.equal (A::_ ccsubspace) B = (A\<le>B \<and> B\<le>A)"
   unfolding equal_ccsubspace_def by auto
 
 lemma apply_cblinfun_code[code]:
   \<comment> \<open>Code equation for applying an operator \<^term>\<open>A\<close> to a subspace. 
       Simply by multiplying each generator with \<^term>\<open>A\<close>\<close>
   "A *\<^sub>S SPAN S = (let d = length (canonical_basis :: 'a list) in
          SPAN (map (mult_mat_vec (mat_of_cblinfun A))
                (filter (\<lambda>v. dim_vec v = d) S)))"
   for A::"'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L'b::onb_enum"
 proof -
   define dA dB S'
     where "dA = length (canonical_basis :: 'a list)"
       and "dB = length (canonical_basis :: 'b list)"
       and "S' = filter (\<lambda>v. dim_vec v = dA) S"
 
   have "cblinfun_image A (SPAN S) = A *\<^sub>S ccspan (set (map basis_enum_of_vec S'))"
     unfolding SPAN_def dA_def[symmetric] Let_def S'_def filter_set
     by simp
   also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec 
             (mat_of_cblinfun A *\<^sub>v vec_of_basis_enum (basis_enum_of_vec x :: 'a))) ` set S')"
     apply (subst cblinfun_apply_ccspan_using_vec)
     by (simp add: image_image)
   also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec (mat_of_cblinfun A *\<^sub>v x)) ` set S')"
     apply (subst image_cong[OF refl])
      apply (subst basis_enum_of_vec_inverse)
     by (auto simp add: S'_def dA_def)
   also have "\<dots> = SPAN (map (mult_mat_vec (mat_of_cblinfun A)) S')"
     unfolding SPAN_def dB_def[symmetric] Let_def filter_set 
     apply (subst filter_True)
     by (simp_all add: dB_def mat_of_cblinfun_def image_image)
 
   finally show ?thesis
     unfolding dA_def[symmetric] S'_def[symmetric] Let_def
     by simp
 qed
 
 definition [code del, code_abbrev]: "range_cblinfun_code A = A *\<^sub>S top"
   \<comment> \<open>A new constant for the special case of applying an operator to the subspace \<^term>\<open>top\<close>
   (i.e., for computing the range of the operator). We do this to be able to give
   more specialized code for this specific situation. (The generic code for
   \<^term>\<open>(*\<^sub>S)\<close> would work but is less efficient because it involves repeated matrix 
   multiplications. @{attribute code_abbrev} makes sure occurrences of \<^term>\<open>A *\<^sub>S top\<close>
   are replaced before starting the actual code generation.\<close>
 
 lemma range_cblinfun_code[code]: 
   \<comment> \<open>Code equation for computing the range of an operator \<^term>\<open>A\<close>.
       Returns the columns of the matrix representation of \<^term>\<open>A\<close>.\<close>
   fixes A :: "'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L 'b::onb_enum"
   shows "range_cblinfun_code A = SPAN (cols (mat_of_cblinfun A))"
 proof -
   define dA dB
     where "dA = length (canonical_basis :: 'a list)"
       and "dB = length (canonical_basis :: 'b list)"
   have carrier_A: "mat_of_cblinfun A \<in> carrier_mat dB dA"
     unfolding mat_of_cblinfun_def dA_def dB_def by simp
 
   have "range_cblinfun_code A = A *\<^sub>S SPAN (unit_vecs dA)"
     unfolding range_cblinfun_code_def
     by (metis dA_def top_ccsubspace_code)
   also have "\<dots> = SPAN (map (\<lambda>i. mat_of_cblinfun A *\<^sub>v unit_vec dA i) [0..<dA])"
     unfolding apply_cblinfun_code dA_def[symmetric] Let_def
     apply (subst filter_True)
      apply (meson carrier_vecD subset_code(1) unit_vecs_carrier)
     by (simp add: unit_vecs_def o_def)
   also have "\<dots> = SPAN (map (\<lambda>x. mat_of_cblinfun A *\<^sub>v col (1\<^sub>m dA) x) [0..<dA])"
     apply (subst map_cong[OF refl])
     by auto
   also have "\<dots> = SPAN (map (col (mat_of_cblinfun A * 1\<^sub>m dA)) [0..<dA])"
     apply (subst map_cong[OF refl])
      apply (subst col_mult2[symmetric])
         apply (rule carrier_A)
     by auto
   also have "\<dots> = SPAN (cols (mat_of_cblinfun A))"
     unfolding cols_def dA_def[symmetric]
     apply (subst right_mult_one_mat[OF carrier_A])
     using carrier_A by blast
   finally show ?thesis
     by -
 qed
 
 
 lemma uminus_Span_code[code]: "- X = range_cblinfun_code (id_cblinfun - Proj X)"
   \<comment> \<open>Code equation for the orthogonal complement of a subspace \<^term>\<open>X\<close>. 
       Computed as the range of one minus the projector on \<^term>\<open>X\<close>\<close>
   unfolding range_cblinfun_code_def
   by (metis Proj_ortho_compl Proj_range)
 
 lemma kernel_code[code]: 
   \<comment> \<open>Computes the kernel of an operator \<^term>\<open>A\<close>.
       This is implemented using the existing functions 
       for transforming a matrix into row echelon form (\<^term>\<open>gauss_jordan_single\<close>)
       and for computing a basis of the kernel of such a matrix
       (\<^term>\<open>find_base_vectors\<close>)\<close>
   "kernel A = SPAN (find_base_vectors (gauss_jordan_single (mat_of_cblinfun A)))" 
   for A::"('a::onb_enum,'b::onb_enum) cblinfun"
 proof -
   define dA dB Am Ag base
     where "dA = length (canonical_basis :: 'a list)"
       and "dB = length (canonical_basis :: 'b list)"
       and "Am = mat_of_cblinfun A"
       and "Ag = gauss_jordan_single Am"
       and "base = find_base_vectors Ag"
 
   interpret complex_vec_space dA.
 
   have Am_carrier: "Am \<in> carrier_mat dB dA"
     unfolding Am_def mat_of_cblinfun_def dA_def dB_def by simp
 
   have row_echelon: "row_echelon_form Ag"
     unfolding Ag_def
     using Am_carrier refl by (rule gauss_jordan_single)
 
   have Ag_carrier: "Ag \<in> carrier_mat dB dA"
     unfolding Ag_def
     using Am_carrier refl by (rule gauss_jordan_single(2))
 
   have base_carrier: "set base \<subseteq> carrier_vec dA"
     unfolding base_def
     using find_base_vectors(1)[OF row_echelon Ag_carrier]
     using Ag_carrier mat_kernel_def by blast
 
   interpret k: kernel dB dA Ag
     apply standard using Ag_carrier by simp
 
   have basis_base: "kernel.basis dA Ag (set base)"
     using row_echelon Ag_carrier unfolding base_def
     by (rule find_base_vectors(3))
 
 
   have "space_as_set (SPAN base)
        = space_as_set (ccspan (basis_enum_of_vec ` set base :: 'a set))"
     unfolding SPAN_def dA_def[symmetric] Let_def filter_set
     apply (subst filter_True)
     using base_carrier by auto
 
   also have "\<dots> = cspan (basis_enum_of_vec ` set base)"
     apply transfer apply (subst closure_finite_cspan)
     by simp_all
 
   also have "\<dots> = basis_enum_of_vec ` span (set base)"
     apply (subst basis_enum_of_vec_span)
     using base_carrier dA_def by auto
 
   also have "\<dots> = basis_enum_of_vec ` mat_kernel Ag"
     using basis_base k.Ker.basis_def k.span_same by auto
 
   also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Ag *\<^sub>v v = 0\<^sub>v dB}"
     apply (rule arg_cong[where f="\<lambda>x. basis_enum_of_vec ` x"])
     unfolding mat_kernel_def using Ag_carrier
     by simp
 
   also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}"
     using gauss_jordan_single(1)[OF Am_carrier Ag_def[symmetric]]
     by auto
 
   also have "\<dots> = {w. A *\<^sub>V w = 0}"
   proof -
     have "basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}
         = basis_enum_of_vec ` {v \<in> carrier_vec dA. A *\<^sub>V basis_enum_of_vec v = 0}"
       apply (rule arg_cong[where f="\<lambda>t. basis_enum_of_vec ` t"])
       apply (rule Collect_cong)
       apply (simp add: Am_def)
       by (metis Am_carrier Am_def carrier_matD(2) carrier_vecD dB_def mat_carrier 
           mat_of_cblinfun_def mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_inverse 
           basis_enum_of_vec_inverse vec_of_basis_enum_zero)
     also have "\<dots> = {w \<in> basis_enum_of_vec ` carrier_vec dA. A *\<^sub>V w = 0}"
       apply (subst Compr_image_eq[symmetric])
       by simp
     also have "\<dots> = {w. A *\<^sub>V w = 0}"
       apply auto
       by (metis (no_types, lifting) Am_carrier Am_def carrier_matD(2) carrier_vec_dim_vec dim_vec_of_basis_enum' image_iff mat_carrier mat_of_cblinfun_def vec_of_basis_enum_inverse)
     finally show ?thesis
       by -
   qed
 
   also have "\<dots> = space_as_set (kernel A)"
     apply transfer by auto
 
   finally have "SPAN base = kernel A"
     by (simp add: space_as_set_inject)
   then show ?thesis
     by (simp add: base_def Ag_def Am_def)
 qed
 
 lemma inf_ccsubspace_code[code]: 
   \<comment> \<open>Code equation for intersection of subspaces.
      Reduced to orthogonal complement and sum of subspaces
      for which we already have code equations.\<close>
   "(A::'a::onb_enum ccsubspace) \<sqinter> B = - (- A \<squnion> - B)"
   by (subst ortho_involution[symmetric], subst compl_inf, simp)
 
 lemma Sup_ccsubspace_code[code]:
   \<comment> \<open>Supremum (sum) of a set of subspaces. Implemented
      by repeated pairwise sum.\<close>
   "Sup (Set_Monad l :: 'a::onb_enum ccsubspace set) = fold sup l bot"
   unfolding Set_Monad_def
   by (simp add: Sup_set_fold)
 
 
 lemma Inf_ccsubspace_code[code]: 
   \<comment> \<open>Infimum (intersection) of a set of subspaces. 
       Implemented by the orthogonal complement of the supremum.\<close>
   "Inf (Set_Monad l :: 'a::onb_enum ccsubspace set)
   = - Sup (Set_Monad (map uminus l))"
   unfolding Set_Monad_def
   apply (induction l)
   by auto
 
 subsection \<open>Miscellanea\<close>
 
 text \<open>This is a hack to circumvent a bug in the code generation. The automatically
   generated code for the class \<^class>\<open>uniformity\<close> has a type that is different from
   what the generated code later assumes, leading to compilation errors (in ML at least)
   in any expression involving \<^typ>\<open>_ ell2\<close> (even if the constant \<^const>\<open>uniformity\<close> is
   not actually used).
   
   The fragment below circumvents this by forcing Isabelle to use the right type.
   (The logically useless fragment "\<open>let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_)\<close>" achieves this.)\<close>
 lemma uniformity_ell2_code[code]: "(uniformity :: ('a ell2 * _) filter) = Filter.abstract_filter (%_.
     Code.abort STR ''no uniformity'' (%_. 
     let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_) in uniformity))"
   by simp
 
 text \<open>Code equation for \<^term>\<open>UNIV\<close>. 
   It is now implemented via type class \<^class>\<open>enum\<close> 
   (which provides a list of all values).\<close>
 declare [[code drop: UNIV]]
 declare enum_class.UNIV_enum[code]
 
 text \<open>Setup for code generation involving sets of \<^type>\<open>ell2\<close>/\<^type>\<open>ccsubspace\<close>.
   This configures to use lists for representing sets in code.\<close>
 derive (eq) ceq ccsubspace
 derive (no) ccompare ccsubspace
 derive (monad) set_impl ccsubspace
 derive (eq) ceq ell2
 derive (no) ccompare ell2
 derive (monad) set_impl ell2
 
 
+unbundle no_lattice_syntax
 unbundle no_jnf_notation
 unbundle no_cblinfun_notation
 
 end
diff --git a/thys/Complex_Bounded_Operators/Cblinfun_Code_Examples.thy b/thys/Complex_Bounded_Operators/Cblinfun_Code_Examples.thy
--- a/thys/Complex_Bounded_Operators/Cblinfun_Code_Examples.thy
+++ b/thys/Complex_Bounded_Operators/Cblinfun_Code_Examples.thy
@@ -1,119 +1,120 @@
 section \<open>\<open>Cblinfun_Code_Examples\<close> -- Examples and test cases for code generation\<close>
 
 theory Cblinfun_Code_Examples
   imports
     "Complex_Bounded_Operators.Extra_Pretty_Code_Examples"
     Jordan_Normal_Form.Matrix_Impl
     "HOL-Library.Code_Target_Numeral"
     Cblinfun_Code
 begin
 
 hide_const (open) Order.bottom Order.top
 no_notation Lattice.join (infixl "\<squnion>\<index>" 65)
 no_notation Lattice.meet (infixl "\<sqinter>\<index>" 70)
 
+unbundle lattice_syntax
 unbundle cblinfun_notation
 
 section \<open>Examples\<close>
 
 subsection \<open>Operators\<close>
 
 value "id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "1 :: unit ell2 \<Rightarrow>\<^sub>C\<^sub>L unit ell2"
 
 value "id_cblinfun + id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "0 :: (bool ell2 \<Rightarrow>\<^sub>C\<^sub>L Enum.finite_3 ell2)"
 
 value "- id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "id_cblinfun - id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "classical_operator (\<lambda>b. Some (\<not> b))"
 
 value "id_cblinfun = (0 :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2)"
 
 value "2 *\<^sub>R id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "imaginary_unit *\<^sub>C id_cblinfun :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "id_cblinfun o\<^sub>C\<^sub>L 0 :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 value "id_cblinfun* :: bool ell2 \<Rightarrow>\<^sub>C\<^sub>L bool ell2"
 
 subsection \<open>Vectors\<close>
 
 value "0 :: bool ell2"
 
 value "1 :: unit ell2"
 
 value "ket False"
 
 value "2 *\<^sub>C ket False"
 
 value "2 *\<^sub>R ket False"
 
 value "ket True + ket False"
 
 value "ket True - ket True"
 
 value "ket True = ket True"
 
 value "- ket True"
 
 value "cinner (ket True) (ket True)"
 
 value "norm (ket True)"
 
 value "ket () * ket ()"
 
 value "1 :: unit ell2"
 
 value "(1::unit ell2) * (1::unit ell2)"
 
 subsection \<open>Vector/Matrix\<close>
 
 value "id_cblinfun *\<^sub>V ket True"
 
 value \<open>vector_to_cblinfun (ket True) :: unit ell2 \<Rightarrow>\<^sub>C\<^sub>L _\<close>
 
 subsection \<open>Subspaces\<close>
 
 value "ccspan {ket False}"
 
 value "Proj (ccspan {ket False})"
 
 value "top :: bool ell2 ccsubspace"
 
 value "bot :: bool ell2 ccsubspace"
 
 value "0 :: bool ell2 ccsubspace"
 
 value "ccspan {ket False} \<squnion> ccspan {ket True}"
 
 value "ccspan {ket False} + ccspan {ket True}"
 
 value "ccspan {ket False} \<sqinter> ccspan {ket True}"
 
 value "id_cblinfun *\<^sub>S ccspan {ket False}"
 
 value "id_cblinfun *\<^sub>S (top :: bool ell2 ccsubspace)" (* Special case, using range_cblinfun_code for efficiency *)
 
 value "- ccspan {ket False}"
 
 value "ccspan {ket False, ket True} = top"
 
 value "ccspan {ket False} \<le> ccspan {ket True}"
 
 value "cblinfun_image id_cblinfun (ccspan {ket True})"
 
 value "kernel id_cblinfun :: bool ell2 ccsubspace"
 
 value "eigenspace 1 id_cblinfun :: bool ell2 ccsubspace"
 
 value "Inf {ccspan {ket False}, top}"
 
 value "Sup {ccspan {ket False}, top}"
 
 end
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,2981 +1,2984 @@
 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
     Complex_Inner_Product One_Dimensional_Spaces
     Banach_Steinhaus.Banach_Steinhaus
     "HOL-Types_To_Sets.Types_To_Sets"
     Complex_Bounded_Linear_Function0
 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 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: Complex_Vector_Spaces0.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
 
 
 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)
 
 
 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: Complex_Vector_Spaces0.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::chilbert_space\<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 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
 
 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
 
 
 
 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 Complex_Vector_Spaces0.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
 
 
 
 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
 
 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_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)
 
 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
 
 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)
 
 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 positive_cblinfunI: \<open>A \<ge> 0\<close> if \<open>\<And>x. cinner x (A *\<^sub>V x) \<ge> 0\<close>
   unfolding less_eq_cblinfun_def using that by auto
 
 (* 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
 
 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_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
 
 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
 
 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_exists_bounded_dense:
   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 \<open>cblinfun_extension_exists S f\<close>
 proof -
   obtain B where bounded: \<open>\<And>x. x \<in> S \<Longrightarrow> norm (f x) \<le> B * norm x\<close> and \<open>B > 0\<close>
     using bounded by (smt (z3) mult_mono norm_ge_zero)
   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
 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)
 
 subsection \<open>Notation\<close>
 
 bundle cblinfun_notation begin
 notation cblinfun_compose (infixl "o\<^sub>C\<^sub>L" 55)
 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" 55)
 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_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,1462 +1,1463 @@
 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_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
 
 
 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 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
 
 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
 
 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:
   assumes "inj_map \<pi>"
   shows "classical_operator_exists \<pi>"
 proof -
   define f where \<open>f t = (case \<pi> (inv ket t) of None \<Rightarrow> 0 | Some x \<Rightarrow> ket x)\<close> for t
   define g where \<open>g = cconstruct (range ket) f\<close>
   have g_f: \<open>g (ket x) = f (ket x)\<close> for x
     unfolding g_def apply (rule complex_vector.construct_basis)
     using cindependent_ket by auto
   have \<open>clinear g\<close>
     unfolding g_def apply (rule complex_vector.linear_construct)
     using cindependent_ket by blast
   then have \<open>g (x + y) = g x + g y\<close> if \<open>x \<in> cspan (range ket)\<close> and \<open>y \<in> cspan (range ket)\<close> for x y
     using clinear_iff by blast
   moreover from \<open>clinear g\<close> have \<open>g (c *\<^sub>C x) = c *\<^sub>C g x\<close> if \<open>x \<in> cspan (range ket)\<close> for x c
     by (simp add: complex_vector.linear_scale)
   moreover have \<open>norm (g x) \<le> norm x\<close> if \<open>x \<in> cspan (range ket)\<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> range ket\<close>
       unfolding complex_vector.span_explicit by auto
     then obtain T where tT: \<open>t = ket ` T\<close> and [simp]: \<open>finite T\<close>
       by (meson finite_subset_image)
     define R where \<open>R i = r (ket i)\<close> for i
     have x_sum: \<open>x = (\<Sum>i\<in>T. R i *\<^sub>C ket i)\<close>
       unfolding R_def tT x_sum
       apply (rule sum.reindex_cong)
       by (auto simp add: inj_on_def)
 
     define T' \<pi>' \<pi>T \<pi>R where \<open>T' = {i\<in>T. \<pi> i \<noteq> None}\<close> and \<open>\<pi>' = the o \<pi>\<close> and \<open>\<pi>T = \<pi>' ` T'\<close> and \<open>\<pi>R i = R (inv_into T' \<pi>' i)\<close> for i
     have \<open>inj_on \<pi>' T'\<close>
       by (smt (z3) T'_def \<pi>'_def assms comp_apply inj_map_def inj_on_def mem_Collect_eq option.expand)
     have [simp]: \<open>finite \<pi>T\<close>
       by (simp add: T'_def \<pi>T_def)
 
     have \<open>g x = (\<Sum>i\<in>T. R i *\<^sub>C g (ket i))\<close>
       by (smt (verit, ccfv_threshold) \<open>clinear g\<close> complex_vector.linear_scale complex_vector.linear_sum sum.cong x_sum)
     also have \<open>\<dots> = (\<Sum>i\<in>T. R i *\<^sub>C f (ket i))\<close>
       using g_f by presburger
     also have \<open>\<dots> = (\<Sum>i\<in>T. R i *\<^sub>C (case \<pi> i of None \<Rightarrow> 0 | Some x \<Rightarrow> ket x))\<close>
       unfolding f_def by auto
     also have \<open>\<dots> = (\<Sum>i\<in>T'. R i *\<^sub>C ket (\<pi>' i))\<close>
       apply (rule sum.mono_neutral_cong_right)
       unfolding T'_def \<pi>'_def
       by auto
     also have \<open>\<dots> = (\<Sum>i\<in>\<pi>' ` T'. R (inv_into T' \<pi>' i) *\<^sub>C ket i)\<close>
       apply (subst sum.reindex)
       using \<open>inj_on \<pi>' T'\<close> apply assumption
       apply (rule sum.cong)
       using \<open>inj_on \<pi>' T'\<close> by auto
     finally have gx_sum: \<open>g x = (\<Sum>i\<in>\<pi>T. \<pi>R i *\<^sub>C ket i)\<close>
       using \<pi>R_def \<pi>T_def by auto
 
     have \<open>(norm (g x))\<^sup>2 = (\<Sum>a\<in>\<pi>T. (cmod (\<pi>R a))\<^sup>2)\<close>
       unfolding gx_sum 
       apply (subst pythagorean_theorem_sum)
       by auto
     also have \<open>\<dots> = (\<Sum>i\<in>T'. (cmod (R i))\<^sup>2)\<close>
       unfolding \<pi>R_def \<pi>T_def
       apply (subst sum.reindex)
       using \<open>inj_on \<pi>' T'\<close> apply assumption
       apply (rule sum.cong)
       using \<open>inj_on \<pi>' T'\<close> by auto
     also have \<open>\<dots> \<le> (\<Sum>a\<in>T. (cmod (R a))\<^sup>2)\<close>
       apply (rule sum_mono2)
       using T'_def by auto
     also have \<open>\<dots> = (norm x)\<^sup>2\<close>
       unfolding x_sum 
       apply (subst pythagorean_theorem_sum)
       using \<open>finite T\<close> by auto
     finally show \<open>norm (g x) \<le> norm x\<close>
       by auto
   qed
   ultimately have \<open>cblinfun_extension_exists (cspan (range ket)) g\<close>
     apply (rule_tac cblinfun_extension_exists_bounded_dense[where B=1])
     by auto
 
   then have \<open>cblinfun_extension_exists (range ket) f\<close>
     by (metis (mono_tags, opaque_lifting) g_f cblinfun_extension_apply cblinfun_extension_existsI complex_vector.span_base rangeE)
   then show \<open>classical_operator_exists \<pi>\<close>
     unfolding classical_operator_exists_def f_def by simp
 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,2820 +1,2824 @@
 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"
 
     "Complex_Bounded_Operators.Extra_Vector_Spaces"
     "Complex_Bounded_Operators.Extra_Ordered_Fields"
     "Complex_Bounded_Operators.Extra_Lattice"
     "Complex_Bounded_Operators.Extra_General"
 
     Complex_Vector_Spaces0
 begin
 
 bundle notation_norm begin
 notation norm ("\<parallel>_\<parallel>")
 end
 
+unbundle lattice_syntax
+
 subsection \<open>Misc\<close>
 
 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 clinear) "linear f"
   apply standard
   by (simp_all add: add scaleC scaleR_scaleC)
 
 lemma (in bounded_clinear) bounded_linear: "bounded_linear f"
   by (simp add: add bounded bounded_linear.intro bounded_linear_axioms.intro linearI scaleC scaleR_scaleC)
 
 lemma clinear_times: "clinear (\<lambda>x. c * x)"
   for c :: "'a::complex_algebra"
   by (auto simp: clinearI distrib_left)
 
 lemma (in clinear) linear:
   shows \<open>linear f\<close>
   by (simp add: add linearI scaleC scaleR_scaleC)
 
 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>\<forall>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)
 
 (* The following would be a natural inclusion of locales, but unfortunately it leads to
    name conflicts upon interpretation of bounded_cbilinear *)
 (* sublocale bounded_cbilinear \<subseteq> bounded_bilinear
   by (rule bounded_bilinear) *)
 
 
 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
 
 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> bounded_linear
   apply standard by (fact bounded)
 
 lemma (in bounded_antilinear) bounded_linear: "bounded_linear f"
   by (fact 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> bounded_bilinear
   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 (fact bounded_bilinear_axioms)
 
 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) 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 bounded_bilinear \<open>(\<lambda>x. prod (g x))\<close>
     by (simp add: bounded_linear comp1)
   show "\<exists>K. \<forall>a b. norm (prod (g a) b) \<le> norm a * norm b * K"
     using 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 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 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>
 
 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
 
 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)
 
 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 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
 
 
 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)
 
 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)+
 
 
 subsection \<open>Copying existing theorems into sublocales\<close>
 
 context bounded_clinear begin
 interpretation bounded_linear f by (rule bounded_linear)
 lemmas continuous = continuous
 lemmas uniform_limit = uniform_limit
 lemmas Cauchy = Cauchy
 end
 
 context bounded_antilinear begin
 interpretation bounded_linear f by (rule bounded_linear)
 lemmas continuous = continuous
 lemmas uniform_limit = uniform_limit
 end
 
 
 context bounded_cbilinear begin
 interpretation bounded_bilinear prod by simp
 lemmas tendsto = tendsto
 lemmas isCont = isCont
 end
 
 context bounded_sesquilinear begin
 interpretation bounded_bilinear prod by simp
 lemmas tendsto = tendsto
 lemmas isCont = isCont
 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_Lattice.thy b/thys/Complex_Bounded_Operators/extra/Extra_Lattice.thy
--- a/thys/Complex_Bounded_Operators/extra/Extra_Lattice.thy
+++ b/thys/Complex_Bounded_Operators/extra/Extra_Lattice.thy
@@ -1,271 +1,249 @@
 section \<open>\<open>Extra_Lattice\<close> -- Additional results about lattices\<close>
 
 theory Extra_Lattice
   imports Main
 begin
 
 
 subsection\<open>\<open>Lattice_Missing\<close> -- Miscellaneous missing facts about lattices\<close>
 
-text \<open>Two bundles to activate and deactivate lattice specific notation (e.g., \<open>\<sqinter>\<close> etc.).
-  Activate the notation locally via "@{theory_text \<open>includes lattice_notation\<close>}" in a lemma statement.
-  (Or sandwich a declaration using that notation between "@{theory_text \<open>unbundle lattice_notation ... unbundle no_lattice_notation\<close>}.)\<close>
-
-bundle lattice_notation begin
-notation inf (infixl "\<sqinter>" 70)
-notation sup (infixl "\<squnion>" 65)
-notation Inf ("\<Sqinter>")
-notation Sup ("\<Squnion>")
-notation bot ("\<bottom>")
-notation top ("\<top>")
-end
-
-bundle no_lattice_notation begin
-notation inf (infixl "\<sqinter>" 70)
-notation sup (infixl "\<squnion>" 65)
-notation Inf ("\<Sqinter>")
-notation Sup ("\<Squnion>")
-notation bot ("\<bottom>")
-notation top ("\<top>")
-end
-
-unbundle lattice_notation
+unbundle lattice_syntax
 
 text \<open>The following class \<open>complemented_lattice\<close> describes complemented lattices (with
   \<^const>\<open>uminus\<close> for the complement). The definition follows
   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Definition_and_basic_properties\<close>.
   Additionally, it adopts the convention from \<^class>\<open>boolean_algebra\<close> of defining
   \<^const>\<open>minus\<close> in terms of the complement.\<close>
 
 class complemented_lattice = bounded_lattice + uminus + minus +
   assumes inf_compl_bot[simp]: "inf x (-x) = bot"
     and sup_compl_top[simp]: "sup x (-x) = top"
     and diff_eq:  "x - y = inf x (- y)" begin
 
 lemma dual_complemented_lattice:
   "class.complemented_lattice (\<lambda>x y. x \<squnion> (- y)) uminus sup greater_eq greater inf \<top> \<bottom>"
 proof (rule class.complemented_lattice.intro)
   show "class.bounded_lattice (\<squnion>) (\<lambda>x y. (y::'a) \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
     by (rule dual_bounded_lattice)
   show "class.complemented_lattice_axioms (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<sqinter>) \<top> \<bottom>"
     by (unfold_locales, auto simp add: diff_eq)
 qed
 
 
 lemma compl_inf_bot [simp]: "inf (- x) x = bot"
   by (simp add: inf_commute)
 
 lemma compl_sup_top [simp]: "sup (- x) x = top"
   by (simp add: sup_commute)
 
 end
 
 class complete_complemented_lattice = complemented_lattice + complete_lattice
 
 text \<open>The following class \<open>complemented_lattice\<close> describes orthocomplemented lattices,
   following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthocomplementation\<close>.\<close>
 class orthocomplemented_lattice = complemented_lattice +
   assumes ortho_involution[simp]: "- (- x) = x"
     and ortho_antimono: "x \<le> y \<Longrightarrow> -x \<ge> -y" begin
 
 lemma dual_orthocomplemented_lattice:
   "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus sup greater_eq greater inf \<top> \<bottom>"
 proof (rule class.orthocomplemented_lattice.intro)
   show "class.complemented_lattice (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
     by (rule dual_complemented_lattice)
   show "class.orthocomplemented_lattice_axioms uminus (\<lambda>x y. (y::'a) \<le> x)"
     by (unfold_locales, auto simp add: diff_eq intro: ortho_antimono)
 qed
 
 
 
 lemma compl_eq_compl_iff [simp]: "- x = - y \<longleftrightarrow> x = y"
   by (metis ortho_involution)
 
 lemma compl_bot_eq [simp]: "- bot = top"
   by (metis inf_compl_bot inf_top_left ortho_involution)
 
 lemma compl_top_eq [simp]: "- top = bot"
   using compl_bot_eq ortho_involution by blast
 
 text \<open>De Morgan's law\<close>
   (* Proof from: https://planetmath.org/orthocomplementedlattice *)
 lemma compl_sup [simp]: "- (x \<squnion> y) = - x \<sqinter> - y"
 proof -
   have "- (x \<squnion> y) \<le> - x"
     by (simp add: ortho_antimono)
   moreover have "- (x \<squnion> y) \<le> - y"
     by (simp add: ortho_antimono)
   ultimately have 1: "- (x \<squnion> y) \<le> - x \<sqinter> - y"
     by (simp add: sup.coboundedI1)
   have \<open>x \<le> - (-x \<sqinter> -y)\<close>
     by (metis inf.cobounded1 ortho_antimono ortho_involution)
   moreover have \<open>y \<le> - (-x \<sqinter> -y)\<close>
     by (metis inf.cobounded2 ortho_antimono ortho_involution)
   ultimately have \<open>x \<squnion> y \<le> - (-x \<sqinter> -y)\<close>
     by auto
   hence 2: \<open>-x \<sqinter> -y \<le> - (x \<squnion> y)\<close>
     using ortho_antimono by fastforce
   from 1 2 show ?thesis
     using dual_order.antisym by blast
 qed
 
 text \<open>De Morgan's law\<close>
 lemma compl_inf [simp]: "- (x \<sqinter> y) = - x \<squnion> - y"
   using compl_sup
   by (metis ortho_involution)
 
 lemma compl_mono:
   assumes "x \<le> y"
   shows "- y \<le> - x"
   by (simp add: assms local.ortho_antimono)
 
 lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x"
   by (auto dest: compl_mono)
 
 lemma compl_le_swap1:
   assumes "y \<le> - x"
   shows "x \<le> -y"
   using assms ortho_antimono by fastforce
 
 lemma compl_le_swap2:
   assumes "- y \<le> x"
   shows "- x \<le> y"
   using assms local.ortho_antimono by fastforce
 
 lemma compl_less_compl_iff[simp]: "- x < - y \<longleftrightarrow> y < x"
   by (auto simp add: less_le)
 
 lemma compl_less_swap1:
   assumes "y < - x"
   shows "x < - y"
   using assms compl_less_compl_iff by fastforce
 
 lemma compl_less_swap2:
   assumes "- y < x"
   shows "- x < y"
   using assms compl_le_swap1 compl_le_swap2 less_le_not_le by auto
 
 lemma sup_cancel_left1: "sup (sup x a) (sup (- x) b) = top"
   by (simp add: sup_commute sup_left_commute)
 
 lemma sup_cancel_left2: "sup (sup (- x) a) (sup x b) = top"
   by (simp add: sup.commute sup_left_commute)
 
 lemma inf_cancel_left1: "inf (inf x a) (inf (- x) b) = bot"
   by (simp add: inf.left_commute inf_commute)
 
 lemma inf_cancel_left2: "inf (inf (- x) a) (inf x b) = bot"
   using inf.left_commute inf_commute by auto
 
 lemma sup_compl_top_left1 [simp]: "sup (- x) (sup x y) = top"
   by (simp add: sup_assoc[symmetric])
 
 lemma sup_compl_top_left2 [simp]: "sup x (sup (- x) y) = top"
   using sup_compl_top_left1[of "- x" y] by simp
 
 lemma inf_compl_bot_left1 [simp]: "inf (- x) (inf x y) = bot"
   by (simp add: inf_assoc[symmetric])
 
 lemma inf_compl_bot_left2 [simp]: "inf x (inf (- x) y) = bot"
   using inf_compl_bot_left1[of "- x" y] by simp
 
 lemma inf_compl_bot_right [simp]: "inf x (inf y (- x)) = bot"
   by (subst inf_left_commute) simp
 
 end
 
 class complete_orthocomplemented_lattice = orthocomplemented_lattice + complete_lattice
 
 instance complete_orthocomplemented_lattice \<subseteq> complete_complemented_lattice
   by intro_classes
 
 text \<open>The following class \<open>orthomodular_lattice\<close> describes orthomodular lattices,
 following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthomodular_lattices\<close>.\<close>
 class orthomodular_lattice = orthocomplemented_lattice +
   assumes orthomodular: "x \<le> y \<Longrightarrow> sup x (inf (-x) y) = y" begin
 
 lemma dual_orthomodular_lattice:
   "class.orthomodular_lattice (\<lambda>x y. x \<squnion> - y) uminus sup greater_eq greater inf \<top> \<bottom>"
 proof (rule class.orthomodular_lattice.intro)
   show "class.orthocomplemented_lattice (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
     by (rule dual_orthocomplemented_lattice)
   show "class.orthomodular_lattice_axioms uminus (\<squnion>) (\<lambda>x y. (y::'a) \<le> x) (\<sqinter>)"
   proof (unfold_locales)
     show "(x::'a) \<sqinter> (- x \<squnion> y) = y"
       if "(y::'a) \<le> x"
       for x :: 'a
         and y :: 'a
       using that local.compl_eq_compl_iff local.ortho_antimono local.orthomodular by fastforce
   qed
 
 qed
 
 
 end
 
 class complete_orthomodular_lattice = orthomodular_lattice + complete_lattice begin
 
 end
 
 instance complete_orthomodular_lattice \<subseteq> complete_orthocomplemented_lattice
   by intro_classes
 
 
 instance boolean_algebra \<subseteq> orthomodular_lattice
 proof
   fix x y :: 'a
   show "sup (x::'a) (inf (- x) y) = y"
     if "(x::'a) \<le> y"
     using that
     by (simp add: sup.absorb_iff2 sup_inf_distrib1)
   show "x - y = inf x (- y)"
     by (simp add: boolean_algebra_class.diff_eq)
 qed auto
 
 instance complete_boolean_algebra \<subseteq> complete_orthomodular_lattice
   by intro_classes
 
 lemma image_of_maximum:
   fixes f::"'a::order \<Rightarrow> 'b::conditionally_complete_lattice"
   assumes "mono f"
     and "\<And>x. x:M \<Longrightarrow> x\<le>m"
     and "m:M"
   shows "(SUP x\<in>M. f x) = f m"
   by (smt (verit, ccfv_threshold) assms(1) assms(2) assms(3) cSup_eq_maximum imageE imageI monoD)
 
 lemma cSup_eq_cSup:
   fixes A B :: \<open>'a::conditionally_complete_lattice set\<close>
   assumes bdd: \<open>bdd_above A\<close>
   assumes B: \<open>\<And>a. a\<in>A \<Longrightarrow> \<exists>b\<in>B. b \<ge> a\<close>
   assumes A: \<open>\<And>b. b\<in>B \<Longrightarrow> \<exists>a\<in>A. a \<ge> b\<close>
   shows \<open>Sup A = Sup B\<close>
 proof (cases \<open>B = {}\<close>)
   case True
   with A B have \<open>A = {}\<close>
     by auto
   with True show ?thesis by simp
 next
   case False
   have \<open>bdd_above B\<close>
     by (meson A bdd bdd_above_def order_trans)
   have \<open>A \<noteq> {}\<close>
     using A False by blast
   moreover have \<open>a \<le> Sup B\<close> if \<open>a \<in> A\<close> for a
   proof -
     obtain b where \<open>b \<in> B\<close> and \<open>b \<ge> a\<close>
       using B \<open>a \<in> A\<close> by auto
     then show ?thesis
       apply (rule cSup_upper2)
       using \<open>bdd_above B\<close> by simp
   qed
   moreover have \<open>Sup B \<le> c\<close> if \<open>\<And>a. a \<in> A \<Longrightarrow> a \<le> c\<close> for c
     using False apply (rule cSup_least)
     using A that by fastforce
   ultimately show ?thesis
     by (rule cSup_eq_non_empty)
 qed
 
-unbundle no_lattice_notation
+unbundle no_lattice_syntax
 
 end
diff --git a/thys/Registers/Quantum_Extra.thy b/thys/Registers/Quantum_Extra.thy
--- a/thys/Registers/Quantum_Extra.thy
+++ b/thys/Registers/Quantum_Extra.thy
@@ -1,162 +1,163 @@
 section \<open>Derived facts about quantum registers\<close>
 
 theory Quantum_Extra
   imports
     Laws_Quantum
     Quantum
 begin
 
 no_notation meet (infixl "\<sqinter>\<index>" 70)
 no_notation Group.mult (infixl "\<otimes>\<index>" 70)
 no_notation Order.top ("\<top>\<index>")
+unbundle lattice_syntax
 unbundle register_notation
 unbundle cblinfun_notation
 
 lemma zero_not_register[simp]: \<open>~ register (\<lambda>_. 0)\<close>
   unfolding register_def by simp
 
 lemma register_pair_is_register_converse:
   \<open>register (F;G) \<Longrightarrow> register F\<close> \<open>register (F;G) \<Longrightarrow> register G\<close>
   using [[simproc del: Laws_Quantum.compatibility_warn]]
    apply (cases \<open>register F\<close>)
     apply (auto simp: register_pair_def)[2]
   apply (cases \<open>register G\<close>)
   by (auto simp: register_pair_def)[2]
 
 lemma register_id'[simp]: \<open>register (\<lambda>x. x)\<close>
   using register_id by (simp add: id_def)
 
 lemma register_projector:
   assumes "register F"
   assumes "is_Proj a"
   shows "is_Proj (F a)"
   using assms unfolding register_def is_Proj_algebraic by metis
 
 lemma register_unitary:
   assumes "register F"
   assumes "unitary a"
   shows "unitary (F a)"
   using assms by (smt (verit, best) register_def unitary_def)
 
 lemma compatible_proj_intersect:
   (* I think this also holds without is_Proj premises, but my proof ideas use the Penrose-Moore 
      pseudoinverse or simultaneous diagonalization and we do not have an existence theorem for either. *)
   assumes "compatible R S" and "is_Proj a" and "is_Proj b"
   shows "(R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>) = ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)"
 proof (rule antisym)
   have "((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (S b *\<^sub>S \<top>)"
     apply (subst swap_registers[OF assms(1)])
     by (simp add: cblinfun_compose_image cblinfun_image_mono)
   moreover have "((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (R a *\<^sub>S \<top>)"
     by (simp add: cblinfun_compose_image cblinfun_image_mono)
   ultimately show \<open>((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>) \<le> (R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>)\<close>
     by auto
 
   have "is_Proj (R a)"
     using assms(1) assms(2) compatible_register1 register_projector by blast
   have "is_Proj (S b)"
     using assms(1) assms(3) compatible_register2 register_projector by blast
   show \<open>(R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>) \<le> (R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>\<close>
   proof (unfold less_eq_ccsubspace.rep_eq, rule)
     fix \<psi>
     assume asm: \<open>\<psi> \<in> space_as_set ((R a *\<^sub>S \<top>) \<sqinter> (S b *\<^sub>S \<top>))\<close>
     then have \<open>\<psi> \<in> space_as_set (R a *\<^sub>S \<top>)\<close>
       by auto
     then have R: \<open>R a *\<^sub>V \<psi> = \<psi>\<close>
       using \<open>is_Proj (R a)\<close> cblinfun_fixes_range is_Proj_algebraic by blast
     from asm have \<open>\<psi> \<in> space_as_set (S b *\<^sub>S \<top>)\<close>
       by auto
     then have S: \<open>S b *\<^sub>V \<psi> = \<psi>\<close>
       using \<open>is_Proj (S b)\<close> cblinfun_fixes_range is_Proj_algebraic by blast
     from R S have \<open>\<psi> = (R a o\<^sub>C\<^sub>L S b) *\<^sub>V \<psi>\<close>
       by (simp add: cblinfun_apply_cblinfun_compose)
     also have \<open>\<dots> \<in> space_as_set ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)\<close>
       apply simp by (metis R S calculation cblinfun_apply_in_image)
     finally show \<open>\<psi> \<in> space_as_set ((R a o\<^sub>C\<^sub>L S b) *\<^sub>S \<top>)\<close>
       by -
   qed
 qed
 
 lemma compatible_proj_mult:
   assumes "compatible R S" and "is_Proj a" and "is_Proj b"
   shows "is_Proj (R a o\<^sub>C\<^sub>L S b)"
   using [[simproc del: Laws_Quantum.compatibility_warn]]
   using assms unfolding is_Proj_algebraic compatible_def
   apply auto
    apply (metis (no_types, lifting) cblinfun_compose_assoc register_mult)
   by (simp add: assms(2) assms(3) is_proj_selfadj register_projector)
 
 lemma unitary_sandwich_register: \<open>unitary a \<Longrightarrow> register (sandwich a)\<close>
   unfolding register_def
   apply (auto simp: sandwich_def)
    apply (metis (no_types, lifting) cblinfun_assoc_left(1) cblinfun_compose_id_right unitaryD1)
   by (simp add: lift_cblinfun_comp(2))
 
 lemma sandwich_tensor: 
   fixes a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close> 
   assumes \<open>unitary a\<close> \<open>unitary b\<close>
   shows "sandwich (a \<otimes>\<^sub>o b) = sandwich a \<otimes>\<^sub>r sandwich b"
   apply (rule tensor_extensionality)
   by (auto simp: unitary_sandwich_register assms sandwich_def register_tensor_is_register comp_tensor_op tensor_op_adjoint)
 
 lemma sandwich_grow_left: 
   fixes a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a ell2\<close>
   assumes "unitary a"
   shows "sandwich a \<otimes>\<^sub>r id = sandwich (a \<otimes>\<^sub>o id_cblinfun)"
   by (simp add: unitary_sandwich_register assms sandwich_tensor sandwich_id)
 
 lemma register_sandwich: \<open>register F \<Longrightarrow> F (sandwich a b) = sandwich (F a) (F b)\<close>
   by (smt (verit, del_insts) register_def sandwich_def)
 
 lemma assoc_ell2_sandwich: \<open>assoc = sandwich assoc_ell2\<close>
   apply (rule tensor_extensionality3')
     apply (simp_all add: unitary_sandwich_register)[2]
   apply (rule equal_ket)
   apply (case_tac x)
   by (simp add: sandwich_def assoc_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor
            flip: tensor_ell2_ket)
 
 lemma assoc_ell2'_sandwich: \<open>assoc' = sandwich assoc_ell2'\<close>
   apply (rule tensor_extensionality3)
     apply (simp_all add: unitary_sandwich_register)[2]
   apply (rule equal_ket)
   apply (case_tac x)
   by (simp add: sandwich_def assoc'_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor 
            flip: tensor_ell2_ket)
 
 lemma swap_sandwich: "swap = sandwich Uswap"
   apply (rule tensor_extensionality)
     apply (auto simp: sandwich_def)[2]
   apply (rule tensor_ell2_extensionality)
   by (simp add: sandwich_def cblinfun_apply_cblinfun_compose tensor_op_ell2)
 
 lemma id_tensor_sandwich: 
   fixes a :: "'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2"
   assumes "unitary a"
   shows "id \<otimes>\<^sub>r sandwich a = sandwich (id_cblinfun \<otimes>\<^sub>o a)"
   apply (rule tensor_extensionality) 
   using assms by (auto simp: register_tensor_is_register comp_tensor_op sandwich_def tensor_op_adjoint unitary_sandwich_register)
 
 lemma compatible_selfbutter_join:
   assumes [register]: "compatible R S"
   shows "R (selfbutter \<psi>) o\<^sub>C\<^sub>L S (selfbutter \<phi>) = (R; S) (selfbutter (\<psi> \<otimes>\<^sub>s \<phi>))"
   apply (subst register_pair_apply[symmetric, where F=R and G=S])
   using assms by auto
 
 lemma register_mult':
   assumes \<open>register F\<close>
   shows \<open>F a *\<^sub>V F b *\<^sub>V c = F (a o\<^sub>C\<^sub>L b) *\<^sub>V c\<close>
   by (simp add: assms lift_cblinfun_comp(4) register_mult)
 
 lemma register_scaleC:
   assumes \<open>register F\<close> shows \<open>F (c *\<^sub>C a) = c *\<^sub>C F a\<close>
   by (simp add: assms complex_vector.linear_scale)
 
 lemma register_bounded_clinear: \<open>register F \<Longrightarrow> bounded_clinear F\<close>
   using bounded_clinear_finite_dim register_def by blast
 
 lemma register_adjoint: "F (a*) = (F a)*" if \<open>register F\<close>
   using register_def that by blast
 
 end
 
diff --git a/thys/ZFC_in_HOL/Kirby.thy b/thys/ZFC_in_HOL/Kirby.thy
--- a/thys/ZFC_in_HOL/Kirby.thy
+++ b/thys/ZFC_in_HOL/Kirby.thy
@@ -1,1659 +1,1659 @@
 section \<open>Addition and Multiplication of Sets\<close>
 
 theory Kirby
   imports ZFC_Cardinals
 
 begin
 
 subsection \<open>Generalised Addition\<close>
 
 text \<open>Source: Laurence Kirby, Addition and multiplication of sets
       Math. Log. Quart. 53, No. 1, 52-65 (2007) / DOI 10.1002/malq.200610026
       @{url "http://faculty.baruch.cuny.edu/lkirby/mlqarticlejan2007.pdf"}\<close>
 
 subsubsection \<open>Addition is a monoid\<close>
 
 instantiation V :: plus
 begin
 
 text\<open>This definition is credited to Tarski\<close>
 definition plus_V :: "V \<Rightarrow> V \<Rightarrow> V"
   where "plus_V x \<equiv> transrec (\<lambda>f z. x \<squnion> set (f ` elts z))"
 
 instance ..
 end
 
 definition lift :: "V \<Rightarrow> V \<Rightarrow> V"
   where "lift x y \<equiv> set (plus x ` elts y)"
 
 lemma plus: "x + y = x \<squnion> set ((+)x ` elts y)"
   unfolding plus_V_def  by (subst transrec) auto
 
 lemma plus_eq_lift: "x + y = x \<squnion> lift x y"
   unfolding lift_def  using plus by blast
 
 text\<open>Lemma 3.2\<close>
 lemma lift_sup_distrib: "lift x (a \<squnion> b) = lift x a \<squnion> lift x b"
   by (simp add: image_Un lift_def sup_V_def)
 
 lemma lift_Sup_distrib: "small Y \<Longrightarrow> lift x (\<Squnion> Y) = \<Squnion> (lift x ` Y)"
   by (auto simp: lift_def Sup_V_def image_Union)
 
 lemma add_Sup_distrib:
-  fixes x::V shows "y \<noteq> 0 \<Longrightarrow> x + (SUP z\<in>elts y. f z) = (SUP z\<in>elts y. x + f z)"
+  fixes x::V shows "y \<noteq> 0 \<Longrightarrow> x + (\<Squnion>z\<in>elts y. f z) = (\<Squnion>z\<in>elts y. x + f z)"
   by (auto simp: plus_eq_lift SUP_sup_distrib lift_Sup_distrib image_image)
 
 lemma Limit_add_Sup_distrib:
-  fixes x::V shows "Limit \<alpha> \<Longrightarrow> x + (SUP z\<in>elts \<alpha>. f z) = (SUP z\<in>elts \<alpha>. x + f z)"
+  fixes x::V shows "Limit \<alpha> \<Longrightarrow> x + (\<Squnion>z\<in>elts \<alpha>. f z) = (\<Squnion>z\<in>elts \<alpha>. x + f z)"
   using add_Sup_distrib by force
 
 text\<open>Proposition 3.3(ii)\<close>
 instantiation V :: monoid_add
 begin
 instance
 proof
   show "a + b + c = a + (b + c)" for a b c :: V
   proof (induction c rule: eps_induct)
     case (step c)
     have "(a+b) + c = a + b \<squnion> set ((+) (a + b) ` elts c)"
       by (metis plus)
     also have "\<dots> = a \<squnion> lift a b \<squnion> set ((\<lambda>u. a + (b+u)) ` elts c)"
       using plus_eq_lift step.IH by auto
     also have "\<dots> = a \<squnion> lift a (b + c)"
     proof -
       have "lift a b \<squnion> set ((\<lambda>u. a + (b + u)) ` elts c) = lift a (b + c)"
         unfolding lift_def
         by (metis elts_of_set image_image lift_def lift_sup_distrib plus_eq_lift replacement small_elts)
       then show ?thesis
         by (simp add: sup_assoc)
     qed
     also have "\<dots> = a + (b + c)"
       using plus_eq_lift by auto
     finally show ?case .
   qed
   show "0 + x = x" for x :: V
   proof (induction rule: eps_induct)
     case (step x)
     then show ?case
       by (subst plus) auto
   qed
   show "x + 0 = x" for x :: V
     by (subst plus) auto
 qed
 end
 
 lemma lift_0 [simp]: "lift 0 x = x"
   by (simp add: lift_def)
 
 lemma lift_by0 [simp]: "lift x 0 = 0"
   by (simp add: lift_def)
 
 lemma lift_by1 [simp]: "lift x 1 = set{x}"
   by (simp add: lift_def)
 
 lemma add_eq_0_iff [simp]:
   fixes x y::V
   shows "x+y = 0 \<longleftrightarrow> x=0 \<and> y=0"
   proof safe
   show "x = 0" if "x + y = 0"
     by (metis that le_imp_less_or_eq not_less_0 plus sup_ge1)
   then show "y = 0" if "x + y = 0"
     using that by auto
 qed auto
 
 lemma plus_vinsert: "x + vinsert z y = vinsert (x+z) (x + y)"
 proof -
   have f1: "elts (x + y) = elts x \<union> (+) x ` elts y"
     by (metis elts_of_set lift_def plus_eq_lift replacement small_Un small_elts sup_V_def)
   moreover have "lift x (vinsert z y) = set ((+) x ` elts (set (insert z (elts y))))"
     using vinsert_def lift_def by presburger
   ultimately show ?thesis
     by (simp add: vinsert_def plus_eq_lift sup_V_def)
 qed
 
 lemma plus_V_succ_right: "x + succ y = succ (x + y)"
   by (metis plus_vinsert succ_def)
 
 lemma succ_eq_add1: "succ x = x + 1"
   by (simp add: plus_V_succ_right one_V_def)
 
 lemma ord_of_nat_add: "ord_of_nat (m+n) = ord_of_nat m + ord_of_nat n"
   by (induction n) (auto simp: plus_V_succ_right)
 
 lemma succ_0_plus_eq [simp]:
   assumes "\<alpha> \<in> elts \<omega>" 
   shows "succ 0 + \<alpha> = succ \<alpha>"
 proof -
   obtain n where "\<alpha> = ord_of_nat n"
     using assms elts_\<omega> by blast
   then show ?thesis
     by (metis One_nat_def ord_of_nat.simps ord_of_nat_add plus_1_eq_Suc)
 qed
 
 lemma omega_closed_add [intro]:
   assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>+\<beta> \<in> elts \<omega>"
 proof -
   obtain m n where "\<alpha> = ord_of_nat m" "\<beta> = ord_of_nat n"
     using assms elts_\<omega> by auto
   then have "\<alpha>+\<beta> = ord_of_nat (m+n)"
     using ord_of_nat_add by auto
   then show ?thesis
     by (simp add: \<omega>_def)
 qed
 
 lemma mem_plus_V_E:
   assumes l: "l \<in> elts (x + y)"
   obtains "l \<in> elts x" | z where "z \<in> elts y" "l = x + z"
   using l by (auto simp: plus [of x y] split: if_split_asm)
 
 lemma not_add_less_right: assumes "Ord y" shows "\<not> (x + y < x)"
   using assms
 proof (induction rule: Ord_induct)
   case (step i)
   then show ?case
     by (metis less_le_not_le plus sup_ge1)
 qed
 
 lemma not_add_mem_right: "\<not> (x + y \<in> elts x)"
   by (metis sup_ge1 mem_not_refl plus vsubsetD)
 
 text\<open>Proposition 3.3(iii)\<close>
 lemma add_not_less_TC_self: "\<not> x + y \<sqsubset> x"
 proof (induction y arbitrary: x rule: eps_induct)
   case (step y)
   then show ?case
     using less_TC_imp_not_le plus_eq_lift by fastforce
 qed
 
 lemma TC_sup_lift: "TC x \<sqinter> lift x y = 0"
 proof -
   have "elts (TC x) \<inter> elts (set ((+) x ` elts y)) = {}"
     using add_not_less_TC_self by (auto simp: less_TC_def)
   then have "TC x \<sqinter> set ((+) x ` elts y) = set {}"
     by (metis inf_V_def)
   then show ?thesis
     using lift_def by auto
 qed
 
 lemma lift_lift: "lift x (lift y z) = lift (x+y) z"
   using add.assoc  by (auto simp: lift_def)
 
 lemma lift_self_disjoint: "x \<sqinter> lift x u = 0"
   by (metis TC_sup_lift arg_subset_TC inf.absorb_iff2 inf_assoc inf_sup_aci(3) lift_0)
 
 lemma sup_lift_eq_lift:
   assumes "x \<squnion> lift x u = x \<squnion> lift x v"
   shows "lift x u = lift x v"
   by (metis (no_types) assms inf_sup_absorb inf_sup_distrib2 lift_self_disjoint sup_commute sup_inf_absorb)
 
 subsubsection \<open>Deeper properties of addition\<close>
 
 text\<open>Proposition 3.4(i)\<close>
 proposition lift_eq_lift: "lift x y = lift x z \<Longrightarrow> y = z"
 proof (induction y arbitrary: z rule: eps_induct)
   case (step y)
   show ?case
   proof (intro vsubsetI order_antisym)
     show "u \<in> elts z" if "u \<in> elts y" for u
     proof -
       have "x+u \<in> elts (lift x z)"
         using lift_def step.prems that by fastforce
       then obtain v where "v \<in> elts z" "x+u = x+v"
         using lift_def by auto
       then have "lift x u = lift x v"
         using sup_lift_eq_lift by (simp add: plus_eq_lift)
       then have "u=v"
         using step.IH that by blast
       then show ?thesis
         using \<open>v \<in> elts z\<close> by blast
     qed
     show "u \<in> elts y" if "u \<in> elts z" for u
     proof -
       have "x+u \<in> elts (lift x y)"
         using lift_def step.prems that by fastforce
       then obtain v where "v \<in> elts y" "x+u = x+v"
         using lift_def by auto
       then have "lift x u = lift x v"
         using sup_lift_eq_lift by (simp add: plus_eq_lift)
       then have "u=v"
         using step.IH by (metis \<open>v \<in> elts y\<close>)
       then show ?thesis
         using \<open>v \<in> elts y\<close> by auto
     qed
   qed
 qed
 
 corollary inj_lift: "inj_on (lift x) A"
   by (auto simp: inj_on_def dest: lift_eq_lift)
 
 corollary add_right_cancel [iff]:
   fixes x y z::V shows "x+y = x+z \<longleftrightarrow> y=z"
   by (metis lift_eq_lift plus_eq_lift sup_lift_eq_lift)
 
 corollary add_mem_right_cancel [iff]:
   fixes x y z::V shows "x+y \<in> elts (x+z) \<longleftrightarrow> y \<in> elts z"
   apply safe
    apply (metis mem_plus_V_E not_add_mem_right add_right_cancel)
   by (metis ZFC_in_HOL.ext dual_order.antisym elts_vinsert insert_subset order_refl plus_vinsert)
 
 corollary add_le_cancel_left [iff]:
   fixes x y z::V shows "x+y \<le> x+z \<longleftrightarrow> y\<le>z"
   by auto (metis add_mem_right_cancel mem_plus_V_E plus sup_ge1 vsubsetD)
 
 corollary add_less_cancel_left [iff]:
   fixes x y z::V shows "x+y < x+z \<longleftrightarrow> y<z"
   by (simp add: less_le_not_le)
 
 corollary lift_le_self [simp]: "lift x y \<le> x \<longleftrightarrow> y = 0"
   by (auto simp: inf.absorb_iff2 lift_eq_lift lift_self_disjoint)
 
 lemma succ_less_\<omega>_imp: "succ x < \<omega> \<Longrightarrow> x < \<omega>"
   by (metis add_le_cancel_left add.right_neutral le_0 le_less_trans succ_eq_add1)
 
 text\<open>Proposition 3.5\<close>
 lemma card_lift: "vcard (lift x y) = vcard y"
 proof (rule cardinal_cong)
   have "bij_betw ((+)x) (elts y) (elts (lift x y))"
     unfolding bij_betw_def
     by (simp add: inj_on_def lift_def)
   then show "elts (lift x y) \<approx> elts y"
     using eqpoll_def eqpoll_sym by blast
 qed
 
 lemma eqpoll_lift: "elts (lift x y) \<approx> elts y"
   by (metis card_lift cardinal_eqpoll eqpoll_sym eqpoll_trans)
 
 lemma vcard_add: "vcard (x + y) = vcard x \<oplus> vcard y"
   using card_lift [of x y] lift_self_disjoint [of x]
   by (simp add: plus_eq_lift vcard_disjoint_sup)
 
 lemma countable_add:
   assumes "countable (elts A)" "countable (elts B)"
   shows "countable (elts (A+B))"
 proof -
   have "vcard A \<le> \<aleph>0" "vcard B \<le> \<aleph>0"
     using assms countable_iff_le_Aleph0 by blast+
   then have "vcard (A+B) \<le> \<aleph>0"
     unfolding vcard_add
     by (metis Aleph_0 Card_\<omega> InfCard_cdouble_eq InfCard_def cadd_le_mono order_refl)
   then show ?thesis
     by (simp add: countable_iff_le_Aleph0)
 qed
 
 text\<open>Proposition 3.6\<close>
 proposition TC_add: "TC (x + y) = TC x \<squnion> lift x (TC y)"
 proof (induction y rule: eps_induct)
   case (step y)
-  have *: "\<Squnion> (TC ` (+) x ` elts y) = TC x \<squnion> (SUP u\<in>elts y. TC (set ((+) x ` elts u)))"
+  have *: "\<Squnion> (TC ` (+) x ` elts y) = TC x \<squnion> (\<Squnion>u\<in>elts y. TC (set ((+) x ` elts u)))"
     if "elts y \<noteq> {}"
   proof -
     obtain w where "w \<in> elts y"
       using \<open>elts y \<noteq> {}\<close> by blast
     then have "TC x \<le> TC (x + w)"
       by (simp add: step.IH)
-    then have \<dagger>: "TC x \<le> (SUP w\<in>elts y. TC (x + w))"
+    then have \<dagger>: "TC x \<le> (\<Squnion>w\<in>elts y. TC (x + w))"
       using \<open>w \<in> elts y\<close> by blast
     show ?thesis
       using that
       apply (intro conjI ballI impI order_antisym; clarsimp simp add: image_comp \<dagger>)
        apply(metis TC_sup_distrib Un_iff elts_sup_iff plus)
       by (metis TC_least Transset_TC arg_subset_TC le_sup_iff plus vsubsetD)
   qed
   have "TC (x + y) = (x + y) \<squnion> \<Squnion> (TC ` elts (x + y))"
     using TC by blast
   also have "\<dots> = x \<squnion> lift x y \<squnion> \<Squnion> (TC ` elts x) \<squnion> \<Squnion> ((\<lambda>u. TC (x+u)) ` elts y)"
     apply (simp add: plus_eq_lift image_Un Sup_Un_distrib sup.left_commute sup_assoc TC_sup_distrib SUP_sup_distrib)
     apply (simp add: lift_def sup.commute sup_aci *)
     done
   also have "\<dots> = x \<squnion> \<Squnion> (TC ` elts x) \<squnion> lift x y \<squnion> \<Squnion> ((\<lambda>u. TC x \<squnion> lift x (TC u)) ` elts y)"
     by (simp add: sup_aci step.IH)
   also have "\<dots> = TC x \<squnion> lift x y \<squnion> \<Squnion> ((\<lambda>u. lift x (TC u)) ` elts y)"
     by (simp add: sup_aci SUP_sup_distrib flip: TC [of x])
   also have "\<dots> = TC x \<squnion> lift x (y \<squnion> \<Squnion> (TC ` elts y))"
     by (metis (no_types) elts_of_set lift_Sup_distrib image_image lift_sup_distrib replacement small_elts sup_assoc)
   also have "\<dots> = TC x \<squnion> lift x (TC y)"
     by (simp add: TC [of y])
   finally show ?case .
 qed
 
 corollary TC_add': "z \<sqsubset> x + y \<longleftrightarrow> z \<sqsubset> x \<or> (\<exists>v. v \<sqsubset> y \<and> z = x + v)"
   using TC_add by (force simp: less_TC_def lift_def)
 
 text\<open>Corollary 3.7\<close>
 corollary vcard_TC_add: "vcard (TC (x+y)) = vcard (TC x) \<oplus> vcard (TC y)"
   by (simp add: TC_add TC_sup_lift card_lift vcard_disjoint_sup)
 
 text\<open>Corollary 3.8\<close>
 corollary TC_lift:
   assumes "y \<noteq> 0"
   shows "TC (lift x y) = TC x \<squnion> lift x (TC y)"
 proof -
   have "TC (lift x y) = lift x y \<squnion> \<Squnion> ((\<lambda>u. TC(x+u)) ` elts y)"
     unfolding TC [of "lift x y"]  by (simp add: lift_def image_image)
-  also have "\<dots> = lift x y \<squnion> (SUP u\<in>elts y. TC x \<squnion> lift x (TC u))"
+  also have "\<dots> = lift x y \<squnion> (\<Squnion>u\<in>elts y. TC x \<squnion> lift x (TC u))"
     by (simp add: TC_add)
-  also have "\<dots> = lift x y \<squnion> TC x \<squnion> (SUP u\<in>elts y. lift x (TC u))"
+  also have "\<dots> = lift x y \<squnion> TC x \<squnion> (\<Squnion>u\<in>elts y. lift x (TC u))"
     using assms by (auto simp: SUP_sup_distrib)
   also have "\<dots> = TC x \<squnion> lift x (TC y)"
     by (simp add: TC [of y] sup_aci image_image lift_sup_distrib lift_Sup_distrib)
   finally show ?thesis .
 qed
 
 proposition rank_add_distrib: "rank (x+y) = rank x + rank y"
 proof (induction y rule: eps_induct)
   case (step y)
   show ?case
   proof (cases "y=0")
     case False
     then obtain e where e: "e \<in> elts y"
       by fastforce
-    have "rank (x+y) = (SUP u\<in>elts (x \<squnion> ZFC_in_HOL.set ((+) x ` elts y)). succ (rank u))"
+    have "rank (x+y) = (\<Squnion>u\<in>elts (x \<squnion> ZFC_in_HOL.set ((+) x ` elts y)). succ (rank u))"
       by (metis plus rank_Sup)
-    also have "\<dots> = (SUP x\<in>elts x. succ (rank x)) \<squnion> (SUP z\<in>elts y. succ (rank x + rank z))"
+    also have "\<dots> = (\<Squnion>x\<in>elts x. succ (rank x)) \<squnion> (\<Squnion>z\<in>elts y. succ (rank x + rank z))"
       apply (simp add: Sup_Un_distrib image_Un image_image)
       apply (simp add: step cong: SUP_cong_simp)
       done
-    also have "\<dots> = (SUP z \<in> elts y. rank x + succ (rank z))"
+    also have "\<dots> = (\<Squnion>z \<in> elts y. rank x + succ (rank z))"
     proof -
-      have "rank x \<le> (SUP z\<in>elts y. ZFC_in_HOL.succ (rank x + rank z))"
+      have "rank x \<le> (\<Squnion>z\<in>elts y. ZFC_in_HOL.succ (rank x + rank z))"
         using \<open>y \<noteq> 0\<close>
         by (auto simp: plus_eq_lift intro: order_trans [OF _ cSUP_upper [OF e]])
       then show ?thesis
         by (force simp: plus_V_succ_right simp flip: rank_Sup [of x] intro!: order_antisym)
     qed
-    also have "\<dots> = rank x + (SUP z \<in> elts y. succ (rank z))"
+    also have "\<dots> = rank x + (\<Squnion>z \<in> elts y. succ (rank z))"
       by (simp add: add_Sup_distrib False)
     also have "\<dots> = rank x + rank y"
       by (simp add: rank_Sup [of y])
     finally show ?thesis .
   qed auto
 qed
 
 lemma Ord_add [simp]: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> Ord (x+y)"
 proof (induction y rule: eps_induct)
   case (step y)
   then show ?case
     by (metis Ord_rank rank_add_distrib rank_of_Ord)
 qed
 
-lemma add_Sup_distrib_id: "A \<noteq> 0 \<Longrightarrow> x + \<Squnion>(elts A) = (SUP z\<in>elts A. x + z)"
+lemma add_Sup_distrib_id: "A \<noteq> 0 \<Longrightarrow> x + \<Squnion>(elts A) = (\<Squnion>z\<in>elts A. x + z)"
   by (metis add_Sup_distrib image_ident image_image)
 
-lemma add_Limit: "Limit \<alpha> \<Longrightarrow> x + \<alpha> = (SUP z\<in>elts \<alpha>. x + z)"
+lemma add_Limit: "Limit \<alpha> \<Longrightarrow> x + \<alpha> = (\<Squnion>z\<in>elts \<alpha>. x + z)"
   by (metis Limit_add_Sup_distrib Limit_eq_Sup_self image_ident image_image)
 
 lemma add_le_left:
   assumes "Ord \<alpha>" "Ord \<beta>" shows "\<beta> \<le> \<alpha>+\<beta>"
   using \<open>Ord \<beta>\<close>
 proof (induction rule: Ord_induct3)
   case 0
   then show ?case
     by auto
 next
   case (succ \<alpha>)
   then show ?case
     by (auto simp: plus_V_succ_right Ord_mem_iff_lt assms(1))
 next
   case (Limit \<mu>)
-  then have k: "\<mu> = (SUP \<beta> \<in> elts \<mu>. \<beta>)"
+  then have k: "\<mu> = (\<Squnion>\<beta> \<in> elts \<mu>. \<beta>)"
     by (simp add: Limit_eq_Sup_self)
-  also have "\<dots>  \<le> (SUP \<beta> \<in> elts \<mu>. \<alpha> + \<beta>)"
+  also have "\<dots>  \<le> (\<Squnion>\<beta> \<in> elts \<mu>. \<alpha> + \<beta>)"
     using Limit.IH by auto
-  also have "\<dots> = \<alpha> + (SUP \<beta> \<in> elts \<mu>. \<beta>)"
+  also have "\<dots> = \<alpha> + (\<Squnion>\<beta> \<in> elts \<mu>. \<beta>)"
     using Limit.hyps Limit_add_Sup_distrib by presburger
   finally show ?case
     using k by simp
 qed
 
 lemma plus_\<omega>_equals_\<omega>:
   assumes "\<alpha> \<in> elts \<omega>"  shows "\<alpha> + \<omega> = \<omega>"
 proof (rule antisym)
   show "\<alpha> + \<omega> \<le> \<omega>"
     using Ord_trans assms by (auto simp: elim!: mem_plus_V_E)
   show "\<omega> \<le> \<alpha> + \<omega>"
     by (simp add: add_le_left assms)
 qed
 
 lemma one_plus_\<omega>_equals_\<omega> [simp]: "1 + \<omega> = \<omega>"
   by (simp add: one_V_def plus_\<omega>_equals_\<omega>)
 
 subsubsection \<open>Cancellation / set subtraction\<close>
 
 definition vle :: "V \<Rightarrow> V \<Rightarrow> bool" (infix "\<unlhd>" 50)
   where "x \<unlhd> y \<equiv> \<exists>z::V. x+z = y"
 
 lemma vle_refl [iff]: "x \<unlhd> x"
   by (metis (no_types) add.right_neutral vle_def)
 
 lemma vle_antisym: "\<lbrakk>x \<unlhd> y; y \<unlhd> x\<rbrakk> \<Longrightarrow> x = y"
   by (metis V_equalityI plus_eq_lift sup_ge1 vle_def vsubsetD)
 
 lemma vle_trans [trans]: "\<lbrakk>x \<unlhd> y; y \<unlhd> z\<rbrakk> \<Longrightarrow> x \<unlhd> z"
   by (metis add.assoc vle_def)
 
 definition vle_comparable :: "V \<Rightarrow> V \<Rightarrow> bool"
   where "vle_comparable x y \<equiv> x \<unlhd> y \<or> y \<unlhd> x"
 
 text\<open>Lemma 3.13\<close>
 lemma comparable:
   assumes "a+b = c+d"
   shows "vle_comparable a c"
 unfolding vle_comparable_def
 proof (rule ccontr)
   assume non: "\<not> (a \<unlhd> c \<or> c \<unlhd> a)"
   let ?\<phi> = "\<lambda>x. \<forall>z. a+x \<noteq> c+z"
   have "?\<phi> x" for x
   proof (induction x rule: eps_induct)
     case (step x)
     show ?case
     proof (cases "x=0")
       case True
       with non nonzero_less_TC show ?thesis
         using vle_def by auto
     next
       case False
       then obtain v where "v \<in> elts x"
         using trad_foundation by blast
       show ?thesis
       proof clarsimp
         fix z
         assume eq: "a + x = c + z"
         then have "z \<noteq> 0"
           using vle_def non by auto
         have av: "a+v \<in> elts (a+x)"
           by (simp add: \<open>v \<in> elts x\<close>)
         moreover have "a+x = c \<squnion> lift c z"
           using eq plus_eq_lift by fastforce
         ultimately have "a+v \<in> elts (c \<squnion> lift c z)"
           by simp
         moreover
         define u where "u \<equiv> set (elts x - {v})"
         have u: "v \<notin> elts u" and xeq: "x = vinsert v u"
           using \<open>v \<in> elts x\<close> by (auto simp: u_def intro: order_antisym)
         have case1: "a+v \<notin> elts c"
         proof
           assume avc: "a + v \<in> elts c"
           then have "a \<le> c"
             by clarify (metis Un_iff elts_sup_iff eq mem_not_sym mem_plus_V_E plus_eq_lift)
           moreover have "a \<squnion> lift a x = c \<squnion> lift c z"
             using eq by (simp add: plus_eq_lift)
           ultimately have "lift c z \<le> lift a x"
             by (metis inf.absorb_iff2 inf_commute inf_sup_absorb inf_sup_distrib2 lift_self_disjoint sup.commute)
           also have "\<dots> = vinsert (a+v) (lift a u)"
             by (simp add: lift_def vinsert_def xeq)
           finally have *: "lift c z \<le> vinsert (a + v) (lift a u)" .
           have "lift c z \<le> lift a u"
           proof -
             have "a + v \<notin> elts (lift c z)"
               using lift_self_disjoint [of c z] avc V_disjoint_iff by auto
             then show ?thesis
               using * less_eq_V_def by auto
           qed
           { fix e
             assume "e \<in> elts z"
             then have "c+e \<in> elts (lift c z)"
               by (simp add: lift_def)
             then have "c+e \<in> elts (lift a u)"
               using \<open>lift c z \<le> lift a u\<close> by blast
             then obtain y where "y \<in> elts u" "c+e = a+y"
               using lift_def by auto
             then have False
               by (metis elts_vinsert insert_iff step.IH xeq)
           }
           then show False
             using \<open>z \<noteq> 0\<close> by fastforce
         qed
         ultimately show False
           by (metis (no_types) \<open>v \<in> elts x\<close> av case1 eq mem_plus_V_E step.IH)
       qed
     qed
   qed
   then show False
     using assms by blast
 qed
 
 lemma vle1: "x \<unlhd> y \<Longrightarrow> x \<le> y"
   using vle_def plus_eq_lift by auto
 
 lemma vle2: "x \<unlhd> y \<Longrightarrow> x \<sqsubseteq> y"
   by (metis (full_types) TC_add' add.right_neutral le_TC_def vle_def nonzero_less_TC)
 
 lemma vle_iff_le_Ord:
   assumes "Ord \<alpha>" "Ord \<beta>"
   shows "\<alpha> \<unlhd> \<beta> \<longleftrightarrow> \<alpha> \<le> \<beta>"
 proof
   show "\<alpha> \<le> \<beta>" if "\<alpha> \<unlhd> \<beta>"
     using that by (simp add: vle1)
   show "\<alpha> \<unlhd> \<beta>" if "\<alpha> \<le> \<beta>"
     using \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> that
   proof (induction \<alpha> arbitrary: \<beta> rule: Ord_induct)
     case (step \<gamma>)
     then show ?case
       unfolding vle_def
       by (metis Ord_add Ord_linear add_le_left mem_not_refl mem_plus_V_E vsubsetD)
   qed
 qed
 
 lemma add_le_cancel_left0 [iff]:
   fixes x::V shows "x \<le> x+z"
   by (simp add: vle1 vle_def)
 
 lemma add_less_cancel_left0 [iff]:
   fixes x::V shows "x < x+z \<longleftrightarrow> 0<z"
   by (metis add_less_cancel_left add.right_neutral)
 
 lemma le_Ord_diff:
   assumes "\<alpha> \<le> \<beta>" "Ord \<alpha>" "Ord \<beta>"
   obtains \<gamma> where "\<alpha>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>" "Ord \<gamma>"
 proof -
   obtain \<gamma> where \<gamma>: "\<alpha>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>"
     by (metis add_le_cancel_left add_le_left assms vle_def vle_iff_le_Ord)
   then have "Ord \<gamma>"
     using Ord_def Transset_def \<open>Ord \<beta>\<close> by force
   with \<gamma> that show thesis by blast
 qed
 
 lemma plus_Ord_le:
   assumes "\<alpha> \<in> elts \<omega>" "Ord \<beta>" shows "\<alpha>+\<beta> \<le> \<beta>+\<alpha>"
 proof (cases "\<beta> \<in> elts \<omega>")
   case True
   with assms have "\<alpha>+\<beta> = \<beta>+\<alpha>"
     by (auto simp: elts_\<omega> add.commute ord_of_nat_add [symmetric])
   then show ?thesis by simp
 next
   case False
   then have "\<omega> \<le> \<beta>" 
     using Ord_linear2 Ord_mem_iff_lt \<open>Ord \<beta>\<close> by auto
   then obtain \<gamma> where "\<omega>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>" "Ord \<gamma>"
     using \<open>Ord \<beta>\<close> le_Ord_diff by auto
   then have "\<alpha>+\<beta> = \<beta>"
     by (metis add.assoc assms(1) plus_\<omega>_equals_\<omega>)
   then show ?thesis
     by simp
 qed
 
 lemma add_right_mono: "\<lbrakk>\<alpha> \<le> \<beta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> \<le> \<beta>+\<gamma>"
   by (metis add_le_cancel_left add.assoc add_le_left le_Ord_diff)
 
 lemma add_strict_mono: "\<lbrakk>\<alpha> < \<beta>; \<gamma> < \<delta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>; Ord \<delta>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> < \<beta>+\<delta>"
   by (metis order.strict_implies_order add_less_cancel_left add_right_mono le_less_trans)
 
 lemma add_right_strict_mono: "\<lbrakk>\<alpha> \<le> \<beta>; \<gamma> < \<delta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>; Ord \<delta>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> < \<beta>+\<delta>"
   using add_strict_mono le_imp_less_or_eq by blast
 
 lemma Limit_add_Limit [simp]:
   assumes "Limit \<mu>" "Ord \<beta>" shows "Limit (\<beta> + \<mu>)"
   unfolding Limit_def
   proof (intro conjI allI impI)
   show "Ord (\<beta> + \<mu>)"
     using Limit_def assms by auto
   show "0 \<in> elts (\<beta> + \<mu>)"
     using Limit_def add_le_left assms by auto
 next
   fix \<gamma>
   assume "\<gamma> \<in> elts (\<beta> + \<mu>)"
   then consider "\<gamma> \<in> elts \<beta>" | \<xi> where "\<xi> \<in> elts \<mu>" "\<gamma> = \<beta> + \<xi>"
     using mem_plus_V_E by blast
   then show "succ \<gamma> \<in> elts (\<beta> + \<mu>)"
   proof cases
     case 1
     then show ?thesis
       by (metis Kirby.add_strict_mono Limit_def Ord_add Ord_in_Ord Ord_mem_iff_lt assms one_V_def succ_eq_add1)
   next
     case 2
     then show ?thesis
       by (metis Limit_def add_mem_right_cancel assms(1) plus_V_succ_right)
   qed
 qed
 
 
 subsection \<open>Generalised Difference\<close>
 
 definition odiff where "odiff y x \<equiv> THE z::V. (x+z = y) \<or> (z=0 \<and> \<not> x \<unlhd> y)"
 
 lemma vle_imp_odiff_eq: "x \<unlhd> y \<Longrightarrow> x + (odiff y x) = y"
   by (auto simp: vle_def odiff_def)
 
 lemma not_vle_imp_odiff_0: "\<not> x \<unlhd> y \<Longrightarrow> (odiff y x) = 0"
   by (auto simp: vle_def odiff_def)
 
 lemma Ord_odiff_eq:
   assumes "\<alpha> \<le> \<beta>" "Ord \<alpha>" "Ord \<beta>"
   shows "\<alpha> + odiff \<beta> \<alpha> = \<beta>"
   by (simp add: assms vle_iff_le_Ord vle_imp_odiff_eq)
 
 lemma Ord_odiff:
   assumes "Ord \<alpha>" "Ord \<beta>" shows "Ord (odiff \<beta> \<alpha>)"
 proof (cases "\<alpha> \<unlhd> \<beta>")
   case True
   then show ?thesis
     by (metis add_right_cancel assms le_Ord_diff vle1 vle_imp_odiff_eq)
 next
   case False
   then show ?thesis
     by (simp add: odiff_def vle_def)
 qed
 
 lemma Ord_odiff_le:
   assumes  "Ord \<alpha>" "Ord \<beta>" shows "odiff \<beta> \<alpha> \<le> \<beta>"
 proof (cases "\<alpha> \<unlhd> \<beta>")
   case True
   then show ?thesis
     by (metis add_right_cancel assms le_Ord_diff vle1 vle_imp_odiff_eq)
 next
   case False
   then show ?thesis 
     by (simp add: odiff_def vle_def)
 qed
 
 
 lemma odiff_0_right [simp]: "odiff x 0 = x"
   by (metis add.left_neutral vle_def vle_imp_odiff_eq)
 
 lemma odiff_succ: "y \<unlhd> x \<Longrightarrow> odiff (succ x) y = succ (odiff x y)"
   unfolding odiff_def
   by (metis add_right_cancel odiff_def plus_V_succ_right vle_def vle_imp_odiff_eq)
 
 lemma odiff_eq_iff: "z \<unlhd> x \<Longrightarrow> odiff x z = y \<longleftrightarrow> x = z + y"
   by (auto simp: odiff_def vle_def)
 
 lemma odiff_le_iff: "z \<unlhd> x \<Longrightarrow> odiff x z \<le> y \<longleftrightarrow> x \<le> z + y"
   by (auto simp: odiff_def vle_def)
 
 lemma odiff_less_iff: "z \<unlhd> x \<Longrightarrow> odiff x z < y \<longleftrightarrow> x < z + y"
   by (auto simp: odiff_def vle_def)
 
 lemma odiff_ge_iff: "z \<unlhd> x \<Longrightarrow> odiff x z \<ge> y \<longleftrightarrow> x \<ge> z + y"
   by (auto simp: odiff_def vle_def)
 
 lemma Ord_odiff_le_iff: "\<lbrakk>\<alpha> \<le> x; Ord x; Ord \<alpha>\<rbrakk> \<Longrightarrow> odiff x \<alpha> \<le> y \<longleftrightarrow> x \<le> \<alpha> + y"
   by (simp add: odiff_le_iff vle_iff_le_Ord)
 
 lemma odiff_le_odiff:
   assumes "x \<unlhd> y" shows "odiff x z \<le> odiff y z"
 proof (cases "z \<unlhd> x")
   case True
   then show ?thesis
     using assms odiff_le_iff vle1 vle_imp_odiff_eq vle_trans by presburger
 next
   case False
   then show ?thesis
     by (simp add: not_vle_imp_odiff_0)
 qed
 
 lemma Ord_odiff_le_odiff: "\<lbrakk>x \<le> y; Ord x; Ord y\<rbrakk> \<Longrightarrow> odiff x \<alpha> \<le> odiff y \<alpha>"
   by (simp add: odiff_le_odiff vle_iff_le_Ord)
 
 lemma Ord_odiff_less_odiff: "\<lbrakk>\<alpha> \<le> x; x < y; Ord x; Ord y; Ord \<alpha>\<rbrakk> \<Longrightarrow> odiff x \<alpha> < odiff y \<alpha>"
   by (metis Ord_odiff_eq Ord_odiff_le_odiff dual_order.strict_trans less_V_def)
 
 lemma Ord_odiff_less_imp_less: "\<lbrakk>odiff x \<alpha> < odiff y \<alpha>; Ord x; Ord y\<rbrakk> \<Longrightarrow> x < y"
   by (meson Ord_linear2 leD odiff_le_odiff vle_iff_le_Ord)
 
 lemma odiff_add_cancel [simp]: "odiff (x + y) x = y"
   by (simp add: odiff_eq_iff vle_def)
 
 lemma odiff_add_cancel_0 [simp]: "odiff x x = 0"
   by (simp add: odiff_eq_iff)
 
 lemma odiff_add_cancel_both [simp]: "odiff (x + y) (x + z) = odiff y z"
   by (simp add: add.assoc odiff_def vle_def)
 
 
 subsection \<open>Generalised Multiplication\<close>
 
 text \<open>Credited to Dana Scott\<close>
 
 instantiation V :: times
 begin
 
 text\<open>This definition is credited to Tarski\<close>
 definition times_V :: "V \<Rightarrow> V \<Rightarrow> V"
   where "times_V x \<equiv> transrec (\<lambda>f y. \<Squnion> ((\<lambda>u. lift (f u) x) ` elts y))"
 
 instance ..
 end
 
-lemma mult: "x * y = (SUP u\<in>elts y. lift (x * u) x)"
+lemma mult: "x * y = (\<Squnion>u\<in>elts y. lift (x * u) x)"
   unfolding times_V_def  by (subst transrec) (force simp:)
 
 lemma elts_multE:
   assumes "z \<in> elts (x * y)" 
   obtains u v where "u \<in> elts x" "v \<in> elts y" "z = x*v + u" 
   using mult [of x y] lift_def assms by auto
 
 text \<open>Lemma 4.2\<close>
 
 lemma mult_zero_right [simp]:
   fixes x::V shows "x * 0 = 0"
   by (metis ZFC_in_HOL.Sup_empty elts_0 image_empty mult)
 
 lemma mult_insert: "x * (vinsert y z) = x*z \<squnion> lift (x*y) x"
   by (metis (no_types, lifting) elts_vinsert image_insert replacement small_elts sup_commute mult Sup_V_insert)
 
 lemma mult_succ: "x * succ y = x*y + x"
   by (simp add: mult_insert plus_eq_lift succ_def)
 
 lemma ord_of_nat_mult: "ord_of_nat (m*n) = ord_of_nat m * ord_of_nat n"
 proof (induction n)
   case (Suc n)
   then show ?case
     by (simp add: add.commute [of m]) (simp add: ord_of_nat_add mult_succ)
 qed auto
 
 lemma omega_closed_mult [intro]:
   assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>*\<beta> \<in> elts \<omega>"
 proof -
   obtain m n where "\<alpha> = ord_of_nat m" "\<beta> = ord_of_nat n"
     using assms elts_\<omega> by auto
   then have "\<alpha>*\<beta> = ord_of_nat (m*n)"
     by (simp add: ord_of_nat_mult)
   then show ?thesis
     by (simp add: \<omega>_def)
 qed
 
 lemma zero_imp_le_mult: "0 \<in> elts y \<Longrightarrow> x \<le> x*y"
   by (auto simp: mult [of x y])
   
 subsubsection\<open>Proposition 4.3\<close>
 
 lemma mult_zero_left [simp]:
   fixes x::V shows "0 * x = 0"
 proof (induction x rule: eps_induct)
   case (step x)
   then show ?case
     by (subst mult) auto
 qed
 
 lemma mult_sup_distrib:
   fixes x::V shows "x * (y \<squnion> z) = x*y \<squnion> x*z"
   unfolding mult [of x "y \<squnion> z"] mult [of x y] mult [of x z]
   by (simp add: Sup_Un_distrib image_Un)
 
 lemma mult_Sup_distrib: "small Y \<Longrightarrow> x * (\<Squnion>Y) = \<Squnion> ((*) x ` Y)" for Y:: "V set"
   unfolding mult [of x "\<Squnion>Y"]
   by (simp add: cSUP_UNION) (metis mult)
 
 lemma mult_lift_imp_distrib: "x * (lift y z) = lift (x*y) (x*z) \<Longrightarrow> x * (y+z) = x*y + x*z"
   by (simp add: mult_sup_distrib plus_eq_lift)
 
 lemma mult_lift: "x * (lift y z) = lift (x*y) (x*z)"
 proof (induction z rule: eps_induct)
   case (step z)
-  have "x * lift y z = (SUP u\<in>elts (lift y z). lift (x * u) x)"
+  have "x * lift y z = (\<Squnion>u\<in>elts (lift y z). lift (x * u) x)"
     using mult by blast
-  also have "\<dots> = (SUP v\<in>elts z. lift (x * (y + v)) x)"
+  also have "\<dots> = (\<Squnion>v\<in>elts z. lift (x * (y + v)) x)"
     using lift_def by auto
-  also have "\<dots> = (SUP v\<in>elts z. lift (x * y + x * v) x)"
+  also have "\<dots> = (\<Squnion>v\<in>elts z. lift (x * y + x * v) x)"
     using mult_lift_imp_distrib step.IH by auto
-  also have "\<dots> = (SUP v\<in>elts z. lift (x * y) (lift (x * v) x))"
+  also have "\<dots> = (\<Squnion>v\<in>elts z. lift (x * y) (lift (x * v) x))"
     by (simp add: lift_lift)
-  also have "\<dots> = lift (x * y) (SUP v\<in>elts z. lift (x * v) x)"
+  also have "\<dots> = lift (x * y) (\<Squnion>v\<in>elts z. lift (x * v) x)"
     by (simp add: image_image lift_Sup_distrib)
   also have "\<dots> = lift (x*y) (x*z)"
     by (metis mult)
   finally show ?case .
 qed
 
 lemma mult_Limit: "Limit \<gamma> \<Longrightarrow> x * \<gamma> = \<Squnion> ((*) x ` elts \<gamma>)"
   by (metis Limit_eq_Sup_self mult_Sup_distrib small_elts)
 
 lemma add_mult_distrib: "x * (y+z) = x*y + x*z" for x::V
   by (simp add: mult_lift mult_lift_imp_distrib)
 
 instantiation V :: monoid_mult
 begin
 instance
 proof
   show "1 * x = x" for x :: V
   proof (induction x rule: eps_induct)
     case (step x)
     then show ?case
       by (subst mult) auto
   qed
   show "x * 1 = x" for x :: V
     by (subst mult) auto
   show "(x * y) * z = x * (y * z)" for x y z::V
   proof (induction z rule: eps_induct)
     case (step z)
-    have "(x * y) * z = (SUP u\<in>elts z. lift (x * y * u) (x * y))"
+    have "(x * y) * z = (\<Squnion>u\<in>elts z. lift (x * y * u) (x * y))"
       using mult by blast
-    also have "\<dots> = (SUP u\<in>elts z. lift (x * (y * u)) (x * y))"
+    also have "\<dots> = (\<Squnion>u\<in>elts z. lift (x * (y * u)) (x * y))"
       using step.IH by auto
-    also have "\<dots> = (SUP u\<in>elts z. x * lift (y * u) y)"
+    also have "\<dots> = (\<Squnion>u\<in>elts z. x * lift (y * u) y)"
       using mult_lift by auto
-    also have "\<dots> = x * (SUP u\<in>elts z. lift (y * u) y)"
+    also have "\<dots> = x * (\<Squnion>u\<in>elts z. lift (y * u) y)"
       by (simp add: image_image mult_Sup_distrib)
     also have "\<dots> = x * (y * z)"
       by (metis mult)
     finally show ?case .
   qed
 qed
 
 end
 
 lemma le_mult:
   assumes "Ord \<beta>" "\<beta> \<noteq> 0" shows "\<alpha> \<le> \<alpha> * \<beta>"
   using assms
 proof (induction rule: Ord_induct3)
   case (succ \<alpha>)
   then show ?case
     using mult_insert succ_def by fastforce
 next
   case (Limit \<mu>)
   have "\<alpha> \<in> (*) \<alpha> ` elts \<mu>"
     using Limit.hyps Limit_def one_V_def by (metis imageI mult.right_neutral)
   then have "\<alpha> \<le> \<Squnion> ((*) \<alpha> ` elts \<mu>)"
     by auto
   then show ?case
     by (simp add: Limit.hyps mult_Limit)
 qed auto
 
 lemma mult_sing_1 [simp]:
   fixes x::V shows "x * set{1} = lift x x"
   by (subst mult) auto
 
 lemma mult_2_right [simp]:
   fixes x::V shows "x * set{0,1} = x+x"
   by (subst mult) (auto simp: Sup_V_insert plus_eq_lift)
 
 lemma Ord_mult [simp]: "\<lbrakk>Ord y; Ord x\<rbrakk> \<Longrightarrow> Ord (x*y)"
 proof (induction y rule: Ord_induct3)
   case 0
   then show ?case
     by auto
 next
   case (succ k)
   then show ?case
     by (simp add: mult_succ)
 next
   case (Limit k)
   then have "Ord (x * \<Squnion> (elts k))"
     by (metis Ord_Sup imageE mult_Sup_distrib small_elts)
   then show ?case
     using Limit.hyps Limit_eq_Sup_self by auto
 qed
 
 
 subsubsection \<open>Proposition 4.4-5\<close>
 proposition rank_mult_distrib: "rank (x*y) = rank x * rank y"
 proof (induction y rule: eps_induct)
   case (step y)
-  have "rank (x*y) = (SUP y\<in>elts (SUP u\<in>elts y. lift (x * u) x). succ (rank y))"
+  have "rank (x*y) = (\<Squnion>y\<in>elts (\<Squnion>u\<in>elts y. lift (x * u) x). succ (rank y))"
     by (metis rank_Sup mult)
-  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank (x * u + r)))"
+  also have "\<dots> = (\<Squnion>u\<in>elts y. \<Squnion>r\<in>elts x. succ (rank (x * u + r)))"
     apply (simp add: lift_def image_image image_UN)
     apply (simp add: Sup_V_def)
     done
-  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank (x * u) + rank r))"
+  also have "\<dots> = (\<Squnion>u\<in>elts y. \<Squnion>r\<in>elts x. succ (rank (x * u) + rank r))"
     using rank_add_distrib by auto
-  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank x * rank u + rank r))"
+  also have "\<dots> = (\<Squnion>u\<in>elts y. \<Squnion>r\<in>elts x. succ (rank x * rank u + rank r))"
     using step arg_cong [where f = Sup] by auto
-  also have "\<dots> = (SUP u\<in>elts y. rank x * rank u + rank x)"
+  also have "\<dots> = (\<Squnion>u\<in>elts y. rank x * rank u + rank x)"
   proof (rule SUP_cong)
-    show "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + rank x"
+    show "(\<Squnion>r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + rank x"
       if "u \<in> elts y" for u
     proof (cases "x=0")
       case False
-      have "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + (SUP y\<in>elts x. succ (rank y))"
+      have "(\<Squnion>r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + (\<Squnion>y\<in>elts x. succ (rank y))"
       proof (rule order_antisym)
-        show "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) \<le> rank x * rank u + (SUP y\<in>elts x. succ (rank y))"
+        show "(\<Squnion>r\<in>elts x. succ (rank x * rank u + rank r)) \<le> rank x * rank u + (\<Squnion>y\<in>elts x. succ (rank y))"
           by (auto simp: Sup_le_iff simp flip: plus_V_succ_right)
-        have "rank x * rank u + (SUP y\<in>elts x. succ (rank y)) = (SUP y\<in>elts x. rank x * rank u + succ (rank y))"
+        have "rank x * rank u + (\<Squnion>y\<in>elts x. succ (rank y)) = (\<Squnion>y\<in>elts x. rank x * rank u + succ (rank y))"
           by (simp add: add_Sup_distrib False)
-        also have "\<dots> \<le> (SUP r\<in>elts x. succ (rank x * rank u + rank r))"
+        also have "\<dots> \<le> (\<Squnion>r\<in>elts x. succ (rank x * rank u + rank r))"
           using plus_V_succ_right by auto
-        finally show "rank x * rank u + (SUP y\<in>elts x. succ (rank y)) \<le> (SUP r\<in>elts x. succ (rank x * rank u + rank r))" .
+        finally show "rank x * rank u + (\<Squnion>y\<in>elts x. succ (rank y)) \<le> (\<Squnion>r\<in>elts x. succ (rank x * rank u + rank r))" .
       qed
       also have "\<dots> = rank x * rank u + rank x"
         by (metis rank_Sup)
       finally show ?thesis .
     qed auto
   qed auto
   also have "\<dots> = rank x * rank y"
     by (simp add: rank_Sup [of y] mult_Sup_distrib mult_succ image_image)
   finally show ?case .
 qed
 
 lemma mult_le1:
   fixes y::V assumes "y \<noteq> 0" shows "x \<sqsubseteq> x * y"
 proof (cases "x = 0")
   case False
   then obtain r where r: "r \<in> elts x"
     by fastforce
   from \<open>y \<noteq> 0\<close> show ?thesis
   proof (induction y rule: eps_induct)
     case (step y)
     show ?case
     proof (cases "y = 1")
       case False
       with \<open>y \<noteq> 0\<close> obtain p where p: "p \<in> elts y" "p \<noteq> 0"
         by (metis V_equalityI elts_1 insertI1 singletonD trad_foundation)
       then have "x*p + r \<in> elts (lift (x*p) x)"
         by (simp add: lift_def r)
       moreover have "lift (x*p) x \<le> x*y"
         by (metis bdd_above_iff_small cSUP_upper2 order_refl \<open>p \<in> elts y\<close> replacement small_elts mult)
       ultimately have "x*p + r \<in> elts (x*y)"
         by blast
       moreover have "x*p \<sqsubseteq> x*p + r"
         by (metis TC_add' V_equalityI add.right_neutral eps_induct le_TC_refl less_TC_iff less_imp_le_TC)
       ultimately show ?thesis
         using step.IH [OF p] le_TC_trans less_TC_iff by blast
     qed auto
   qed
 qed auto
 
 lemma mult_eq_0_iff [simp]:
   fixes y::V shows "x * y = 0 \<longleftrightarrow> x=0 \<or> y=0"
 proof
   show "x = 0 \<or> y = 0" if "x * y = 0"
     by (metis le_0 le_TC_def less_TC_imp_not_le mult_le1 that)
 qed auto
 
 lemma lift_lemma:
   assumes "x \<noteq> 0" "y \<noteq> 0"  shows "\<not> lift (x * y) x \<le> x"
   using assms mult_le1 [of concl: x y]
   by (auto simp: le_TC_def TC_lift less_TC_def less_TC_imp_not_le)
 
 lemma mult_le2:
   fixes y::V assumes "x \<noteq> 0" "y \<noteq> 0" "y \<noteq> 1" shows "x \<sqsubset> x * y"
 proof -
   obtain v where v: "v \<in> elts y" "v \<noteq> 0"
     using assms by fastforce
   have "x \<noteq> x * y"
     using lift_lemma [of x v]
     by (metis \<open>x \<noteq> 0\<close> bdd_above_iff_small cSUP_upper2 order_refl replacement small_elts mult v)
   then show ?thesis
   using assms mult_le1 [of y x]
     by (auto simp: le_TC_def)
 qed
 
 lemma elts_mult_\<omega>E:
   assumes "x \<in> elts (y * \<omega>)"
   obtains n where "n \<noteq> 0" "x \<in> elts (y * ord_of_nat n)" "\<And>m. m < n \<Longrightarrow> x \<notin> elts (y * ord_of_nat m)"
 proof -
   obtain k where k:  "k \<noteq> 0 \<and> x \<in> elts (y * ord_of_nat k)"
     using assms
     apply (simp add: mult_Limit elts_\<omega>)
     by (metis mult_eq_0_iff elts_0 ex_in_conv ord_of_eq_0_iff that)
   define n where "n \<equiv> (LEAST k. k \<noteq> 0 \<and> x \<in> elts (y * ord_of_nat k))"
   show thesis
   proof
     show "n \<noteq> 0" "x \<in> elts (y * ord_of_nat n)"
       unfolding n_def by (metis (mono_tags, lifting) LeastI_ex k)+
     show "\<And>m. m < n \<Longrightarrow> x \<notin> elts (y * ord_of_nat m)"
       by (metis (mono_tags, lifting) mult_eq_0_iff elts_0 empty_iff n_def not_less_Least ord_of_eq_0_iff)
   qed
 qed
 
 
 subsubsection\<open>Theorem 4.6\<close>
 
 theorem mult_eq_imp_0:
   assumes "a*x = a*y + b" "b \<sqsubset> a"
   shows "b=0"
 proof (cases "a=0 \<or> x=0")
   case True
   with assms show ?thesis
     by (metis add_le_cancel_left mult_eq_0_iff eq_iff le_0)
 next
   case False
   then have "a\<noteq>0" "x\<noteq>0"
     by auto
   then show ?thesis
   proof (cases "y=0")
     case True
     then show ?thesis
       using assms less_asym_TC mult_le2 by force
   next
     case False
     have "b=0" if "Ord \<alpha>" "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)" for \<alpha>
       using that assms
     proof (induction \<alpha> arbitrary: x y b rule: Ord_induct3)
       case 0
       then show ?case by auto
     next
       case (succ k)
       define \<Phi> where "\<Phi> \<equiv> \<lambda>x y. \<exists>r. 0 \<sqsubset> r \<and> r \<sqsubset> a \<and> a*x = a*y + r"
       show ?case
       proof (rule ccontr)
         assume "b \<noteq> 0"
         then have "0 \<sqsubset> b"
           by (metis nonzero_less_TC)
         then have "\<Phi> x y"
           unfolding \<Phi>_def using succ.prems by blast
         then obtain x' where "\<Phi> x' y" "x' \<sqsubseteq> x" and min: "\<And>x''. x'' \<sqsubset> x' \<Longrightarrow> \<not> \<Phi> x'' y"
           using less_TC_minimal [of "\<lambda>x. \<Phi> x y" x] by blast
         then obtain b' where "0 \<sqsubset> b'" "b' \<sqsubset> a" and eq: "a*x' = a*y + b'"
           using \<Phi>_def by blast
         have "a*y \<sqsubset> a*x'"
           using TC_add' \<open>0 \<sqsubset> b'\<close> eq by auto
         then obtain p where "p \<in> elts (a * x')" "a * y \<sqsubseteq> p"
           using less_TC_iff by blast
         then have "p \<notin> elts (a * y)"
           using less_TC_iff less_irrefl_TC by blast
         then have "p \<in> \<Union> (elts ` (\<lambda>v. lift (a * v) a) ` elts x')"
           by (metis \<open>p \<in> elts (a * x')\<close> elts_Sup replacement small_elts mult)
         then obtain u c where "u \<in> elts x'" "c \<in> elts a" "p = a*u + c"
           using lift_def by auto
         then have "p \<in> elts (lift (a*y) b')"
           using \<open>p \<in> elts (a * x')\<close> \<open>p \<notin> elts (a * y)\<close> eq plus_eq_lift by auto
         then obtain d where d: "d \<in> elts b'" "p = a*y + d" "p = a*u + c"
           by (metis \<open>p = a * u + c\<close> \<open>p \<in> elts (a * x')\<close> \<open>p \<notin> elts (a * y)\<close> eq mem_plus_V_E)
         have noteq: "a*y \<noteq> a*u"
         proof
           assume "a*y = a*u"
           then have "lift (a*y) a = lift (a*u) a"
             by metis
           also have "\<dots> \<le> a*x'"
             unfolding mult [of _ x'] using \<open>u \<in> elts x'\<close> by (auto intro: cSUP_upper)
           also have "\<dots> = a*y \<squnion> lift (a*y) b'"
             by (simp add: eq plus_eq_lift)
           finally have "lift (a*y) a \<le> a*y \<squnion> lift (a*y) b'" .
           then have "lift (a*y) a \<le> lift (a*y) b'"
             using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \<open>b' \<sqsubset> a\<close> by auto
           then have "a \<le> b'"
             by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
           then show False
             using \<open>b' \<sqsubset> a\<close> less_TC_imp_not_le by auto
         qed
         consider "a*y \<unlhd> a*u" | "a*u \<unlhd> a*y"
           using d comparable vle_comparable_def by auto
         then show False
         proof cases
           case 1
           then obtain e where e: "a*u = a*y + e" "e \<noteq> 0"
             by (metis add.right_neutral noteq vle_def)
           moreover have "e + c = d"
             by (metis e add_right_cancel \<open>p = a * u + c\<close> \<open>p = a * y + d\<close> add.assoc)
           with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
             by (meson less_TC_iff less_TC_trans vle2 vle_def)
           ultimately show False
             \<comment>\<open>contradicts minimality of @{term x'}\<close>
             using min unfolding \<Phi>_def by (meson \<open>u \<in> elts x'\<close> le_TC_def less_TC_iff nonzero_less_TC)
         next
           case 2
           then obtain e where e: "a*y = a*u + e" "e \<noteq> 0"
             by (metis add.right_neutral noteq vle_def)
           moreover have "e + d = c"
             by (metis e add_right_cancel \<open>p = a * u + c\<close> \<open>p = a * y + d\<close> add.assoc)
           with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
             by (metis \<open>c \<in> elts a\<close> less_TC_iff vle2 vle_def)
           ultimately have "\<Phi> y u"
             unfolding \<Phi>_def using nonzero_less_TC by blast
           then obtain y' where "\<Phi> y' u" "y' \<sqsubseteq> y" and min: "\<And>x''. x'' \<sqsubset> y' \<Longrightarrow> \<not> \<Phi> x'' u"
             using less_TC_minimal [of "\<lambda>x. \<Phi> x u" y] by blast
           then obtain b' where "0 \<sqsubset> b'" "b' \<sqsubset> a" and eq: "a*y' = a*u + b'"
             using \<Phi>_def by blast
           have u_k: "u \<in> elts (Vset k)"
             using \<open>u \<in> elts x'\<close> \<open>x' \<sqsubseteq> x\<close> succ Vset_succ_TC less_TC_iff less_le_TC_trans by blast
           have "a*u \<sqsubset> a*y'"
             using TC_add' \<open>0 \<sqsubset> b'\<close> eq by auto
           then obtain p where "p \<in> elts (a * y')" "a * u \<sqsubseteq> p"
             using less_TC_iff by blast
           then have "p \<notin> elts (a * u)"
             using less_TC_iff less_irrefl_TC by blast
           then have "p \<in> \<Union> (elts ` (\<lambda>v. lift (a * v) a) ` elts y')"
             by (metis \<open>p \<in> elts (a * y')\<close> elts_Sup replacement small_elts mult)
           then obtain v c where "v \<in> elts y'" "c \<in> elts a" "p = a*v + c"
             using lift_def by auto
           then have "p \<in> elts (lift (a*u) b')"
             using \<open>p \<in> elts (a * y')\<close> \<open>p \<notin> elts (a * u)\<close> eq plus_eq_lift by auto
           then obtain d where d: "d \<in> elts b'" "p = a*u + d" "p = a*v + c"
             by (metis \<open>p = a * v + c\<close> \<open>p \<in> elts (a * y')\<close> \<open>p \<notin> elts (a * u)\<close> eq mem_plus_V_E)
           have v_k: "v \<in> elts (Vset k)"
             using Vset_succ_TC \<open>v \<in> elts y'\<close> \<open>y' \<sqsubseteq> y\<close> less_TC_iff less_le_TC_trans succ.hyps succ.prems(2) by blast
           have noteq: "a*u \<noteq> a*v"
             proof
               assume "a*u = a*v"
               then have "lift (a*v) a \<le> a*y'"
                 unfolding mult [of _ y'] using \<open>v \<in> elts y'\<close> by (auto intro: cSUP_upper)
               also have "\<dots> = a*u \<squnion> lift (a*u) b'"
                 by (simp add: eq plus_eq_lift)
               finally have "lift (a*v) a \<le> a*u \<squnion> lift (a*u) b'" .
               then have "lift (a*u) a \<le> lift (a*u) b'"
                 by (metis \<open>a * u = a * v\<close> le_iff_sup lift_sup_distrib sup_left_commute sup_lift_eq_lift)
               then have "a \<le> b'"
                 by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
               then show False
                 using \<open>b' \<sqsubset> a\<close> less_TC_imp_not_le by auto
             qed
           consider "a*u \<unlhd> a*v" | "a*v \<unlhd> a*u"
             using d comparable vle_comparable_def by auto
           then show False
           proof cases
             case 1
             then obtain e where e: "a*v = a*u + e" "e \<noteq> 0"
               by (metis add.right_neutral noteq vle_def)
             moreover have "e + c = d"
               by (metis add_right_cancel \<open>p = a * u + d\<close> \<open>p = a * v + c\<close> add.assoc e)
             with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
               by (meson less_TC_iff less_TC_trans vle2 vle_def)
             ultimately show False
               using succ.IH u_k v_k by blast
           next
             case 2
             then obtain e where e: "a*u = a*v + e" "e \<noteq> 0"
               by (metis add.right_neutral noteq vle_def)
             moreover have "e + d = c"
               by (metis add_right_cancel add.assoc d e)
             with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
               by (metis \<open>c \<in> elts a\<close> less_TC_iff vle2 vle_def)
            ultimately show False
              using succ.IH u_k v_k by blast
           qed
         qed
       qed
     next
       case (Limit k)
       obtain i j where k: "i \<in> elts k" "j \<in> elts k"
         and x: "x \<in> elts (Vset i)"
         and y: "y \<in> elts (Vset j)"
         using that Limit by (auto simp: Limit_Vfrom_eq)
       show ?case
       proof (rule Limit.IH [of "i \<squnion> j"])
         show "i \<squnion> j \<in> elts k"
           by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff)
         show "x \<in> elts (Vset (i \<squnion> j))" "y \<in> elts (Vset (i \<squnion> j))"
           using x y by (auto simp: Vfrom_sup)
       qed (use Limit.prems in auto)
     qed
     then show ?thesis
       by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt)
   qed
 qed
 
 subsubsection\<open>Theorem 4.7\<close>
 
 lemma mult_cancellation_half:
   assumes "a*x + r \<le> a*y + s" "r \<sqsubset> a" "s \<sqsubset> a"
   shows "x \<le> y"
 proof -
   have "x \<le> y" if "Ord \<alpha>" "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)" for \<alpha>
     using that assms
   proof (induction \<alpha> arbitrary: x y r s rule: Ord_induct3)
     case 0
     then show ?case
       by auto
   next
     case (succ k)
     show ?case
     proof
       fix u
       assume u: "u \<in> elts x"
       have u_k: "u \<in> elts (Vset k)"
         using Vset_succ succ.hyps succ.prems(1) u by auto
       obtain r' where "r' \<in> elts a" "r \<sqsubseteq> r'"
         using less_TC_iff succ.prems(4) by blast
       have "a*u + r' \<in> elts (lift (a*u) a)"
         by (simp add: \<open>r' \<in> elts a\<close> lift_def)
       also have "\<dots> \<le> elts (a*x)"
         using u by (force simp: mult [of _ x])
       also have "\<dots> \<le> elts (a*y + s)"
         using plus_eq_lift succ.prems(3) by auto
       also have "\<dots> = elts (a*y) \<union> elts (lift (a*y) s)"
         by (simp add: plus_eq_lift)
       finally have "a * u + r' \<in> elts (a * y) \<union> elts (lift (a * y) s)" .
       then show "u \<in> elts y"
       proof
         assume *: "a * u + r' \<in> elts (a * y)"
         show "u \<in> elts y"
         proof -
           obtain v e where v: "v \<in> elts y" "e \<in> elts a" "a * u + r' = a * v + e"
             using * by (auto simp: mult [of _ y] lift_def)
           then have v_k: "v \<in> elts (Vset k)"
             using Vset_succ_TC less_TC_iff succ.prems(2) by blast
           then show ?thesis
             by (metis \<open>r' \<in> elts a\<close> antisym le_TC_refl less_TC_iff order_refl succ.IH u_k v)
         qed
       next
         assume "a * u + r' \<in> elts (lift (a * y) s)"
         then obtain t where "t \<in> elts s" and t: "a * u + r' = a * y + t"
           using lift_def by auto
         have noteq: "a*y \<noteq> a*u"
         proof
           assume "a*y = a*u"
           then have "lift (a*y) a = lift (a*u) a"
             by metis
           also have "\<dots> \<le> a*x"
             unfolding mult [of _ x] using \<open>u \<in> elts x\<close> by (auto intro: cSUP_upper)
           also have "\<dots> \<le> a*y \<squnion> lift (a*y) s"
             using \<open>elts (a * x) \<subseteq> elts (a * y + s)\<close> plus_eq_lift by auto
           finally have "lift (a*y) a \<le> a*y \<squnion> lift (a*y) s" .
           then have "lift (a*y) a \<le> lift (a*y) s"
             using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \<open>s \<sqsubset> a\<close> by auto
           then have "a \<le> s"
             by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
           then show False
             using \<open>s \<sqsubset> a\<close> less_TC_imp_not_le by auto
         qed
         consider "a * u \<unlhd> a * y" | "a * y \<unlhd> a * u"
           using t comparable vle_comparable_def by blast
         then have "False"
         proof cases
           case 1
           then obtain c where "a*y = a*u + c"
             by (metis vle_def)
           then have "c+t = r'"
             by (metis add_right_cancel add.assoc t)
           then have "c \<sqsubset> a"
             using \<open>r' \<in> elts a\<close> less_TC_iff vle2 vle_def by force
           moreover have "c \<noteq> 0"
             using \<open>a * y = a * u + c\<close> noteq by auto
           ultimately show ?thesis
             using \<open>a * y = a * u + c\<close> mult_eq_imp_0 by blast
         next
           case 2
           then obtain c where "a*u = a*y + c"
             by (metis vle_def)
           then have "c+r' = t"
             by (metis add_right_cancel add.assoc t)
           then have "c \<sqsubset> a"
             by (metis \<open>t \<in> elts s\<close> less_TC_iff less_TC_trans \<open>s \<sqsubset> a\<close> vle2 vle_def)
           moreover have "c \<noteq> 0"
             using \<open>a * u = a * y + c\<close> noteq by auto
           ultimately show ?thesis
             using \<open>a * u = a * y + c\<close> mult_eq_imp_0 by blast
         qed
         then show "u \<in> elts y" ..
       qed
     qed
   next
     case (Limit k)
     obtain i j where k: "i \<in> elts k" "j \<in> elts k"
       and x: "x \<in> elts (Vset i)" and y: "y \<in> elts (Vset j)"
       using that Limit by (auto simp: Limit_Vfrom_eq)
     show ?case
     proof (rule Limit.IH [of "i \<squnion> j"])
       show "i \<squnion> j \<in> elts k"
         by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff)
       show "x \<in> elts (Vset (i \<squnion> j))" "y \<in> elts (Vset (i \<squnion> j))"
         using x y by (auto simp: Vfrom_sup)
       show "a * x + r \<le> a * y + s"
         by (simp add: Limit.prems)
     qed (auto simp: Limit.prems)
   qed
   then show ?thesis
     by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt)
 qed
 
 theorem mult_cancellation_lemma:
   assumes "a*x + r = a*y + s" "r \<sqsubset> a" "s \<sqsubset> a"
   shows "x=y \<and> r=s"
   by (metis assms leD less_V_def mult_cancellation_half odiff_add_cancel order_refl)
 
 corollary mult_cancellation [simp]:
   fixes a::V
   assumes "a \<noteq> 0"
   shows "a*x = a*y \<longleftrightarrow> x=y"
   by (metis assms nonzero_less_TC mult_cancellation_lemma)
 
 corollary mult_cancellation_less:
   assumes lt: "a*x + r < a*y + s" and "r \<sqsubset> a" "s \<sqsubset> a"
   obtains "x < y" | "x = y" "r < s"
 proof -
   have "x \<le> y"
     by (meson assms dual_order.strict_implies_order mult_cancellation_half)
   then consider "x < y" | "x = y"
     using less_V_def by blast
   with lt that show ?thesis by blast
 qed
 
 corollary lift_mult_TC_disjoint:
   fixes x::V
   assumes "x \<noteq> y"
   shows "lift (a*x) (TC a) \<sqinter> lift (a*y) (TC a) = 0"
   apply (rule V_equalityI)
   using assms
   by (auto simp: less_TC_def inf_V_def lift_def image_iff dest: mult_cancellation_lemma)
 
 corollary lift_mult_disjoint:
   fixes x::V
   assumes "x \<noteq> y"
   shows "lift (a*x) a \<sqinter> lift (a*y) a = 0"
 proof -
   have "lift (a*x) a \<sqinter> lift (a*y) a \<le> lift (a*x) (TC a) \<sqinter> lift (a*y) (TC a)"
     by (metis TC' inf_mono lift_sup_distrib sup_ge1)
   then show ?thesis
     using assms lift_mult_TC_disjoint by auto
 qed
 
 lemma mult_add_mem:
   assumes "a*x + r \<in> elts (a*y)" "r \<sqsubset> a"
   shows "x \<in> elts y" "r \<in> elts a"
 proof -
   obtain v s where v: "a * x + r = a * v + s" "v \<in> elts y" "s \<in> elts a"
     using assms unfolding mult [of a y] lift_def by auto
   then show "x \<in> elts y"
     by (metis arg_subset_TC assms(2) less_TC_def mult_cancellation_lemma vsubsetD)
   show "r \<in> elts a"
     by (metis arg_subset_TC assms(2) less_TC_def mult_cancellation_lemma v(1) v(3) vsubsetD)
 qed
 
 lemma mult_add_mem_0 [simp]: "a*x \<in> elts (a*y) \<longleftrightarrow> x \<in> elts y \<and> 0 \<in> elts a"
   proof -
   have "x \<in> elts y"
     if "a * x \<in> elts (a * y) \<and> 0 \<in> elts a"
     using that   using mult_add_mem [of a x 0]
     using nonzero_less_TC by force
   moreover have "a * x \<in> elts (a * y)"
     if "x \<in> elts y" "0 \<in> elts a"
     using that  by (force simp: image_iff mult [of a y] lift_def)
   ultimately show ?thesis
     by (metis mult_eq_0_iff add.right_neutral mult_add_mem(2) nonzero_less_TC)
 qed
 
 lemma zero_mem_mult_iff: "0 \<in> elts (x*y) \<longleftrightarrow> 0 \<in> elts x \<and> 0 \<in> elts y" 
   by (metis Kirby.mult_zero_right mult_add_mem_0)
 
 lemma zero_less_mult_iff [simp]: "0 < x*y \<longleftrightarrow> 0 < x \<and> 0 < y" if "Ord x" 
   using Kirby.mult_eq_0_iff ZFC_in_HOL.neq0_conv by blast
 
 lemma mult_cancel_less_iff [simp]:
   "\<lbrakk>Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>*\<beta> < \<alpha>*\<gamma> \<longleftrightarrow> \<beta> < \<gamma> \<and> 0 < \<alpha>"
   using mult_add_mem_0 [of \<alpha> \<beta> \<gamma>]
   by (meson Ord_0 Ord_mem_iff_lt Ord_mult)
 
 lemma mult_cancel_le_iff [simp]:
   "\<lbrakk>Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>*\<beta> \<le> \<alpha>*\<gamma> \<longleftrightarrow> \<beta> \<le> \<gamma> \<or> \<alpha>=0"
   by (metis Ord_linear2 Ord_mult eq_iff leD mult_cancel_less_iff mult_cancellation)
 
 lemma mult_Suc_add_less: "\<lbrakk>\<alpha> < \<gamma>; \<beta> < \<gamma>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk>  \<Longrightarrow> \<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat (Suc m) + \<beta>"
   apply (simp add: mult_succ add.assoc)
   by (meson Ord_add Ord_linear2 le_less_trans not_add_less_right)
 
 lemma mult_nat_less_add_less:
   assumes "m < n" "\<alpha> < \<gamma>" "\<beta> < \<gamma>" and ord: "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>"
     shows "\<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat n + \<beta>"
 proof -
   have "Suc m \<le> n"
     using \<open>m < n\<close> by auto
   have "\<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat (Suc m) + \<beta>"
     using assms mult_Suc_add_less by blast
   also have "\<dots> \<le> \<gamma> * ord_of_nat n + \<beta>"
     using Ord_mult Ord_ord_of_nat add_right_mono \<open>Suc m \<le> n\<close> ord mult_cancel_le_iff ord_of_nat_mono_iff by presburger
   finally show ?thesis .
 qed
 
 lemma add_mult_less_add_mult:
   assumes "x < y" "x \<in> elts \<beta>" "y \<in> elts \<beta>" "\<mu> \<in> elts \<alpha>" "\<nu> \<in> elts \<alpha>" "Ord \<alpha>" "Ord \<beta>"
     shows "\<alpha>*x + \<mu> < \<alpha>*y + \<nu>"
 proof -
   obtain "Ord x" "Ord y"
     using Ord_in_Ord assms by blast
   then obtain \<delta> where "0 \<in> elts \<delta>" "y = x + \<delta>"
     by (metis add.right_neutral \<open>x < y\<close> le_Ord_diff less_V_def mem_0_Ord)
   then show ?thesis
     apply (simp add: add_mult_distrib add.assoc)
     by (meson OrdmemD add_le_cancel_left0 \<open>\<mu> \<in> elts \<alpha>\<close> \<open>Ord \<alpha>\<close> less_le_trans zero_imp_le_mult)
 qed
 
 lemma add_mult_less:
   assumes "\<gamma> \<in> elts \<alpha>" "\<nu> \<in> elts \<beta>" "Ord \<alpha>" "Ord \<beta>"
     shows "\<alpha> * \<nu> + \<gamma> \<in> elts (\<alpha> * \<beta>)"
 proof -
   have "Ord \<nu>" 
     using Ord_in_Ord assms by blast
   with assms show ?thesis
     by (metis Ord_mem_iff_lt Ord_succ add_mem_right_cancel mult_cancel_le_iff mult_succ succ_le_iff vsubsetD)
 qed
 
 lemma Ord_add_mult_iff:
   assumes "\<beta> \<in> elts \<gamma>" "\<beta>' \<in> elts \<gamma>" "Ord \<alpha>" "Ord \<alpha>'" "Ord \<gamma>"
   shows "\<gamma> * \<alpha> + \<beta> \<in> elts (\<gamma> * \<alpha>' + \<beta>') \<longleftrightarrow> \<alpha> \<in> elts \<alpha>' \<or> \<alpha> = \<alpha>' \<and> \<beta> \<in> elts \<beta>'" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume L: ?lhs
   show ?rhs
   proof (cases "\<alpha> \<in> elts \<alpha>'")
     case False
     with assms have "\<alpha> = \<alpha>'"
       by (meson L Ord_linear Ord_mult Ord_trans add_mult_less not_add_mem_right)
     then show ?thesis
       using L less_V_def by auto
   qed auto
 next
   assume R: ?rhs
   then show ?lhs
   proof
     assume "\<alpha> \<in> elts \<alpha>'"
     then obtain \<delta> where "\<alpha>' = \<alpha>+\<delta>"
       by (metis OrdmemD assms(3) assms(4) le_Ord_diff less_V_def)
     show ?lhs 
       using assms
       by (meson \<open>\<alpha> \<in> elts \<alpha>'\<close> add_le_cancel_left0 add_mult_less vsubsetD)
   next
     assume "\<alpha> = \<alpha>' \<and> \<beta> \<in> elts \<beta>'"
     then show ?lhs
       using less_V_def by auto
   qed
 qed
 
 lemma vcard_mult: "vcard (x * y) = vcard x \<otimes> vcard y"
 proof -
   have 1: "elts (lift (x * u) x) \<approx> elts x" if "u \<in> elts y" for u
     by (metis cardinal_eqpoll eqpoll_sym eqpoll_trans card_lift)
   have 2: "pairwise (\<lambda>u u'. disjnt (elts (lift (x * u) x)) (elts (lift (x * u') x)))  (elts y)"
     by (simp add: pairwise_def disjnt_def) (metis V_disjoint_iff lift_mult_disjoint)
-  have "x * y = (SUP u\<in>elts y. lift (x * u) x)"
+  have "x * y = (\<Squnion>u\<in>elts y. lift (x * u) x)"
     using mult by blast
   then have "elts (x * y) \<approx> (\<Union>u\<in>elts y. elts (lift (x * u) x))"
     by simp
   also have "\<dots> \<approx> elts y \<times> elts x"
     using Union_eqpoll_Times [OF 1 2] .
   also have "\<dots> \<approx> elts x \<times> elts y"
     by (simp add: times_commute_eqpoll)
   also have "\<dots> \<approx> elts (vcard x) \<times> elts (vcard y)"
     using cardinal_eqpoll eqpoll_sym times_eqpoll_cong by blast
   also have "\<dots> \<approx> elts (vcard x \<otimes> vcard y)"
     by (simp add: cmult_def elts_vcard_VSigma_eqpoll eqpoll_sym)
   finally have "elts (x * y) \<approx> elts (vcard x \<otimes> vcard y)" .
   then show ?thesis
     by (metis cadd_cmult_distrib cadd_def cardinal_cong cardinal_idem vsum_0_eqpoll)
 qed
 
-proposition TC_mult: "TC(x * y) = (SUP r \<in> elts (TC x). SUP u \<in> elts (TC y). set{x * u + r})"
+proposition TC_mult: "TC(x * y) = (\<Squnion>r \<in> elts (TC x). \<Squnion>u \<in> elts (TC y). set{x * u + r})"
 proof (cases "x = 0")
   case False
-  have *: "TC(x * y) = (SUP u \<in> elts (TC y). lift (x * u) (TC x))" for y
+  have *: "TC(x * y) = (\<Squnion>u \<in> elts (TC y). lift (x * u) (TC x))" for y
   proof (induction y rule: eps_induct)
     case (step y)
-    have "TC(x * y) = (SUP u \<in> elts y. TC (lift (x * u) x))"
+    have "TC(x * y) = (\<Squnion>u \<in> elts y. TC (lift (x * u) x))"
       by (simp add: mult [of x y] TC_Sup_distrib image_image)
-    also have "\<dots> = (SUP u \<in> elts y. TC(x * u) \<squnion> lift (x * u) (TC x))"
+    also have "\<dots> = (\<Squnion>u \<in> elts y. TC(x * u) \<squnion> lift (x * u) (TC x))"
       by (simp add: TC_lift False)
-    also have "\<dots> = (SUP u \<in> elts y. (SUP z \<in> elts (TC u). lift (x * z) (TC x)) \<squnion> lift (x * u) (TC x))"
+    also have "\<dots> = (\<Squnion>u \<in> elts y. (\<Squnion>z \<in> elts (TC u). lift (x * z) (TC x)) \<squnion> lift (x * u) (TC x))"
       by (simp add: step)
-    also have "\<dots> = (SUP u \<in> elts (TC y). lift (x * u) (TC x))"
+    also have "\<dots> = (\<Squnion>u \<in> elts (TC y). lift (x * u) (TC x))"
       by (auto simp: TC' [of y] image_Un Sup_Un_distrib TC_Sup_distrib cSUP_UNION SUP_sup_distrib)
     finally show ?case .
   qed
   show ?thesis
     by (force simp: * lift_def)
 qed auto
 
 
 corollary vcard_TC_mult: "vcard (TC(x * y)) = vcard (TC x) \<otimes> vcard (TC y)"
 proof -
   have "(\<Union>u\<in>elts (TC x). \<Union>v\<in>elts (TC y). {x * v + u}) = (\<Union>u\<in>elts (TC x). (\<lambda>v. x * v + u) ` elts (TC y))"
     by (simp add: UNION_singleton_eq_range)
   also have "\<dots> \<approx> (\<Union>x\<in>elts (TC x). elts (lift (TC y * x) (TC y)))"
   proof (rule UN_eqpoll_UN)
     show "(\<lambda>v. x * v + u) ` elts (TC y) \<approx> elts (lift (TC y * u) (TC y))"
       if "u \<in> elts (TC x)" for u
     proof -
       have "inj_on (\<lambda>v. x * v + u) (elts (TC y))"
         by (meson inj_onI less_TC_def mult_cancellation_lemma that)
       then have "(\<lambda>v. x * v + u) ` elts (TC y) \<approx> elts (TC y)"
         by (rule inj_on_image_eqpoll_self)
       also have "\<dots> \<approx> elts (lift (TC y * u) (TC y))"
         by (simp add: eqpoll_lift eqpoll_sym)
       finally show ?thesis .
     qed
     show "pairwise (\<lambda>u ya. disjnt ((\<lambda>v. x * v + u) ` elts (TC y)) ((\<lambda>v. x * v + ya) ` elts (TC y))) (elts (TC x))"
       apply (auto simp: pairwise_def disjnt_def)
       using less_TC_def mult_cancellation_lemma by blast
     show "pairwise (\<lambda>u ya. disjnt (elts (lift (TC y * u) (TC y))) (elts (lift (TC y * ya) (TC y)))) (elts (TC x))"
       apply (auto simp: pairwise_def disjnt_def)
       by (metis Int_iff V_disjoint_iff empty_iff lift_mult_disjoint)
   qed
   also have "\<dots> = elts (TC y * TC x)"
     by (metis elts_Sup image_image mult replacement small_elts)
   finally have "(\<Union>u\<in>elts (TC x). \<Union>v\<in>elts (TC y). {x * v + u}) \<approx> elts (TC y * TC x)" .
   then show ?thesis
     apply (subst cmult_commute)
     by (simp add: TC_mult cardinal_cong flip: vcard_mult)
 qed
 
 lemma countable_mult:
   assumes "countable (elts A)" "countable (elts B)"
   shows "countable (elts (A*B))"
 proof -
   have "vcard A \<le> \<aleph>0" "vcard B \<le> \<aleph>0"
     using assms countable_iff_le_Aleph0 by blast+
   then have "vcard (A*B) \<le> \<aleph>0"
     unfolding vcard_mult
     by (metis InfCard_csquare_eq cmult_le_mono Aleph_0 Card_\<omega> InfCard_def order_refl)
   then show ?thesis
     by (simp add: countable_iff_le_Aleph0)
 qed
 
 subsection \<open>Ordertype properties\<close>
 
 lemma ordertype_image_plus:
   assumes "Ord \<alpha>"
   shows "ordertype ((+) u ` elts \<alpha>) VWF = \<alpha>"
 proof (subst ordertype_VWF_eq_iff)
     have 1: "(u + x, u + y) \<in> VWF" if "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "x < y" for x y
       using that
       by (meson Ord_in_Ord Ord_mem_iff_lt add_mem_right_cancel assms mem_imp_VWF)
   then have 2: "x < y"
     if "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "(u + x, u + y) \<in> VWF" for x y
     using that by (metis Ord_in_Ord Ord_linear_lt VWF_asym assms)
   show "\<exists>f. bij_betw f ((+) u ` elts \<alpha>) (elts \<alpha>) \<and> (\<forall>x\<in>(+) u ` elts \<alpha>. \<forall>y\<in>(+) u ` elts \<alpha>. (f x < f y) = ((x, y) \<in> VWF))"
     using 1 2 unfolding bij_betw_def inj_on_def
     by (rule_tac x="\<lambda>x. odiff x u" in exI) (auto simp: image_iff)
 qed (use assms in auto)
 
 lemma ordertype_diff:
   assumes "\<beta> + \<delta> = \<alpha>" and \<alpha>: "\<delta> \<in> elts \<alpha>" "Ord \<alpha>"
   shows "ordertype (elts \<alpha> - elts \<beta>) VWF = \<delta>"
 proof -
   have *: "elts \<alpha> - elts \<beta> = ((+)\<beta>) ` elts \<delta>"
   proof
     show "elts \<alpha> - elts \<beta> \<subseteq> (+) \<beta> ` elts \<delta>"
       by clarsimp (metis assms(1) image_iff mem_plus_V_E)
     show "(+) \<beta> ` elts \<delta> \<subseteq> elts \<alpha> - elts \<beta>"
       using assms(1) not_add_mem_right by force
   qed
   have "ordertype ((+) \<beta> ` elts \<delta>) VWF = \<delta>"
   proof (subst ordertype_VWF_inc_eq)
     show "elts \<delta> \<subseteq> ON" "ordertype (elts \<delta>) VWF = \<delta>"
       using \<alpha> elts_subset_ON ordertype_eq_Ord by blast+
   qed (use "*" assms elts_subset_ON in auto)
   then show ?thesis
     by (simp add: *)
 qed
 
 lemma ordertype_interval_eq:
   assumes \<alpha>: "Ord \<alpha>" and \<beta>: "Ord \<beta>"
   shows "ordertype ({\<alpha> ..< \<alpha>+\<beta>} \<inter> ON) VWF = \<beta>"
 proof -
   have ON: "(+) \<alpha> ` elts \<beta> \<subseteq> ON"
     using assms Ord_add Ord_in_Ord by blast
   have "({\<alpha> ..< \<alpha>+\<beta>} \<inter> ON) = (+) \<alpha> ` elts \<beta>"
     using assms
     apply (simp add: image_def set_eq_iff)
     by (metis add_less_cancel_left Ord_add Ord_in_Ord Ord_linear2 Ord_mem_iff_lt le_Ord_diff not_add_less_right)
   moreover have "ordertype (elts \<beta>) VWF = ordertype ((+) \<alpha> ` elts \<beta>) VWF"
     using ON \<beta> elts_subset_ON ordertype_VWF_inc_eq by auto
   ultimately show ?thesis
     using \<beta> by auto
 qed
 
 lemma ordertype_Times:
   assumes "small A" "small B" and r: "wf r" "trans r" "total_on A r" and s: "wf s" "trans s" "total_on B s"
   shows "ordertype (A\<times>B) (r <*lex*> s) = ordertype B s * ordertype A r" (is "_ = ?\<beta> * ?\<alpha>")
 proof (subst ordertype_eq_iff)
   show "Ord (?\<beta> * ?\<alpha>)"
     by (intro wf_Ord_ordertype Ord_mult r s; simp)
   define f where "f \<equiv> \<lambda>(x,y). ?\<beta> * ordermap A r x + (ordermap B s y)"
   show "\<exists>f. bij_betw f (A \<times> B) (elts (?\<beta> * ?\<alpha>)) \<and> (\<forall>x\<in>A \<times> B. \<forall>y\<in>A \<times> B. (f x < f y) = ((x, y) \<in> (r <*lex*> s)))"
     unfolding bij_betw_def
   proof (intro exI conjI strip)
     show "inj_on f (A \<times> B)"
     proof (clarsimp simp: f_def inj_on_def)
       fix x y x' y'
       assume "x \<in> A" "y \<in> B" "x' \<in> A" "y' \<in> B"
         and eq: "?\<beta> * ordermap A r x + ordermap B s y = ?\<beta> * ordermap A r x' + ordermap B s y'"
       have "ordermap A r x = ordermap A r x' \<and>
             ordermap B s y = ordermap B s y'"
       proof (rule mult_cancellation_lemma [OF eq])
         show "ordermap B s y \<sqsubset> ?\<beta>"
           using ordermap_in_ordertype [OF \<open>y \<in> B\<close>, of s] less_TC_iff \<open>small B\<close> by blast 
         show "ordermap B s y' \<sqsubset> ?\<beta>"
           using ordermap_in_ordertype [OF \<open>y' \<in> B\<close>, of s] less_TC_iff \<open>small B\<close> by blast 
       qed
       then show "x = x' \<and> y = y'"
         using \<open>x \<in> A\<close> \<open>x' \<in> A\<close> \<open>y \<in> B\<close> \<open>y' \<in> B\<close> r s \<open>small A\<close> \<open>small B\<close> by auto
     qed
     show "f ` (A \<times> B) = elts (?\<beta> * ?\<alpha>)" (is "?lhs = ?rhs")
     proof 
       show "f ` (A \<times> B) \<subseteq> elts (?\<beta> * ?\<alpha>)"
         apply (auto simp: f_def add_mult_less ordermap_in_ordertype wf_Ord_ordertype r s)
         by (simp add: add_mult_less assms ordermap_in_ordertype wf_Ord_ordertype)
       show "elts (?\<beta> * ?\<alpha>) \<subseteq> f ` (A \<times> B)"
       proof (clarsimp simp: f_def image_iff elim !: elts_multE split: prod.split)
         fix u v
         assume u: "u \<in> elts (?\<beta>)" and v: "v \<in> elts ?\<alpha>"
         have "inv_into B (ordermap B s) u \<in> B"
           by (simp add: inv_into_ordermap u)
         moreover have "inv_into A (ordermap A r) v \<in> A"
           by (simp add: inv_into_ordermap v)
         ultimately show "\<exists>x\<in>A. \<exists>y\<in>B. ?\<beta> * v + u = ?\<beta> * ordermap A r x + ordermap B s y"
           by (metis \<open>small A\<close> \<open>small B\<close> bij_betw_inv_into_right ordermap_bij r(1) r(3) s(1) s(3) u v)
       qed
     qed
   next
     fix p q
     assume "p \<in> A \<times> B" and "q \<in> A \<times> B"
     then obtain u v x y where \<section>: "p = (u,v)" "u \<in> A" "v \<in> B" "q = (x,y)" "x \<in> A" "y \<in> B"
       by blast
     show "((f p) < f q) = ((p, q) \<in> (r <*lex*> s))"
     proof
       assume "f p < f q"
       with \<section> assms have "(u, x) \<in> r \<or> u=x \<and> (v, y) \<in> s"
         apply (simp add: f_def)
         by (metis Ord_add Ord_add_mult_iff Ord_mem_iff_lt Ord_mult wf_Ord_ordermap converse_ordermap_mono 
             ordermap_eq_iff ordermap_in_ordertype wf_Ord_ordertype)
       then show "(p,q) \<in> (r <*lex*> s)"
         by (simp add: \<section>)
     next
       assume "(p,q) \<in> (r <*lex*> s)"
       then have "(u, x) \<in> r \<or> u = x \<and> (v, y) \<in> s"
         by (simp add: \<section>)
       then show "f p < f q"
       proof
         assume ux: "(u, x) \<in> r"
         have oo: "\<And>x. Ord (ordermap A r x)" "\<And>y. Ord (ordermap B s y)" 
           by (simp_all add: r s)
         show "f p < f q"
         proof (clarsimp simp: f_def split: prod.split)
           fix a b a' b'
           assume "p = (a, b)" and "q = (a', b')"
           then have "?\<beta> * ordermap A r a + ordermap B s b < ?\<beta> * ordermap A r a'"
             using ux assms \<section>
             by (metis Ord_mult wf_Ord_ordermap OrdmemD Pair_inject add_mult_less ordermap_in_ordertype ordermap_mono wf_Ord_ordertype)
           also have "\<dots> \<le> ?\<beta> * ordermap A r a' + ordermap B s b'"
             by simp
           finally show "?\<beta> * ordermap A r a + ordermap B s b < ?\<beta> * ordermap A r a' + ordermap B s b'" .
         qed
       next
         assume "u = x \<and> (v, y) \<in> s"
         then show "f p < f q"
           using \<section> assms by (fastforce simp: f_def split: prod.split intro: ordermap_mono_less)
       qed 
     qed
   qed 
 qed (use assms small_Times in auto)
 
 end
diff --git a/thys/ZFC_in_HOL/Ordinal_Exp.thy b/thys/ZFC_in_HOL/Ordinal_Exp.thy
--- a/thys/ZFC_in_HOL/Ordinal_Exp.thy
+++ b/thys/ZFC_in_HOL/Ordinal_Exp.thy
@@ -1,589 +1,589 @@
 section \<open>Exponentiation of ordinals\<close>
 
 theory Ordinal_Exp
   imports Kirby
 
 begin
 
 text \<open>Source: Schlöder, Julian.  Ordinal Arithmetic; available online at
     \url{http://www.math.uni-bonn.de/ag/logik/teaching/2012WS/Set%20theory/oa.pdf}\<close>
 
 definition oexp :: "[V,V] \<Rightarrow> V" (infixr "\<up>" 80)
   where "oexp a b \<equiv> transrec (\<lambda>f x. if x=0 then 1
-                                    else if Limit x then if a=0 then 0 else SUP \<xi> \<in> elts x. f \<xi>
+                                    else if Limit x then if a=0 then 0 else \<Squnion>\<xi> \<in> elts x. f \<xi>
                                     else f (\<Squnion>(elts x)) * a)  b"
 
 text \<open>@{term "0\<up>\<omega> = 1"} if we don't make a special case for Limit ordinals and zero\<close>
 
 
 lemma oexp_0_right [simp]: "\<alpha>\<up>0 = 1"
   by (simp add: def_transrec [OF oexp_def])
 
 lemma oexp_succ [simp]: "Ord \<beta> \<Longrightarrow> \<alpha>\<up>(succ \<beta>) = \<alpha>\<up>\<beta> * \<alpha>"
   by (simp add: def_transrec [OF oexp_def])
 
-lemma oexp_Limit: "Limit \<beta> \<Longrightarrow> \<alpha>\<up>\<beta> = (if \<alpha>=0 then 0 else SUP \<xi> \<in> elts \<beta>. \<alpha>\<up>\<xi>)"
+lemma oexp_Limit: "Limit \<beta> \<Longrightarrow> \<alpha>\<up>\<beta> = (if \<alpha>=0 then 0 else \<Squnion>\<xi> \<in> elts \<beta>. \<alpha>\<up>\<xi>)"
   by (auto simp: def_transrec [OF oexp_def, of _ \<beta>])
 
 lemma oexp_1_right [simp]: "\<alpha>\<up>1 = \<alpha>"
   using one_V_def oexp_succ by fastforce
 
 lemma oexp_1 [simp]: "Ord \<alpha> \<Longrightarrow> 1\<up>\<alpha> = 1"
   by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)
 
 lemma oexp_0 [simp]: "Ord \<alpha> \<Longrightarrow> 0\<up>\<alpha> = (if \<alpha> = 0 then 1 else 0)"
   by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)
 
 lemma oexp_eq_0_iff [simp]:
   assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> = 0 \<longleftrightarrow> \<alpha>=0 \<and> \<beta>\<noteq>0"
   using \<open>Ord \<beta>\<close>
 proof (induction rule: Ord_induct3)
   case (Limit \<mu>)
   then show ?case
     using Limit_def oexp_Limit by auto
 qed auto
 
 lemma oexp_gt_0_iff [simp]:
   assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> > 0 \<longleftrightarrow> \<alpha>>0 \<or> \<beta>=0"
   by (simp add: assms less_V_def)
 
 lemma ord_of_nat_oexp: "ord_of_nat (m^n) = ord_of_nat m\<up>ord_of_nat n"
 proof (induction n)
   case (Suc n)
   then show ?case
     by (simp add: mult.commute [of m]) (simp add: ord_of_nat_mult)
 qed auto
 
 lemma omega_closed_oexp [intro]:
   assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>\<up>\<beta> \<in> elts \<omega>"
 proof -
   obtain m n where "\<alpha> = ord_of_nat m" "\<beta> = ord_of_nat n"
     using assms elts_\<omega> by auto
   then have "\<alpha>\<up>\<beta> = ord_of_nat (m^n)"
     by (simp add: ord_of_nat_oexp)
   then show ?thesis
     by (simp add: \<omega>_def)
 qed
 
 
 lemma Ord_oexp [simp]:
   assumes "Ord \<alpha>" "Ord \<beta>" shows "Ord (\<alpha>\<up>\<beta>)"
   using \<open>Ord \<beta>\<close>
 proof (induction rule: Ord_induct3)
   case (Limit \<alpha>)
   then show ?case
     by (auto simp: oexp_Limit image_iff intro: Ord_Sup)
 qed (auto intro: Ord_mult assms)
 
 text \<open>Lemma 3.19\<close>
 lemma le_oexp:
   assumes "Ord \<alpha>" "Ord \<beta>" "\<beta> \<noteq> 0" shows "\<alpha> \<le> \<alpha>\<up>\<beta>"
   using \<open>Ord \<beta>\<close> \<open>\<beta> \<noteq> 0\<close>
 proof (induction rule: Ord_induct3)
   case (succ \<beta>)
   then show ?case
     by simp (metis \<open>Ord \<alpha>\<close> le_0 le_mult mult.left_neutral oexp_0_right order_refl order_trans)
 next
   case (Limit \<mu>)
   then show ?case
     by (metis Limit_def Limit_eq_Sup_self ZFC_in_HOL.Sup_upper eq_iff image_eqI image_ident oexp_1_right oexp_Limit replacement small_elts one_V_def)
 qed auto
 
 
 text \<open>Lemma 3.20\<close>
 lemma le_oexp':
   assumes "Ord \<alpha>" "1 < \<alpha>" "Ord \<beta>" shows "\<beta> \<le> \<alpha>\<up>\<beta>"
 proof (cases "\<beta> = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   show ?thesis
     using \<open>Ord \<beta>\<close>
   proof (induction rule: Ord_induct3)
     case 0
     then show ?case
       by auto
   next
     case (succ \<gamma>)
     then have "\<alpha>\<up>\<gamma> * 1 < \<alpha>\<up>\<gamma> * \<alpha>"
       using \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close>
       by (metis le_mult less_V_def mult.right_neutral mult_cancellation not_less_0 oexp_eq_0_iff succ.hyps)
     then have " \<gamma> < \<alpha>\<up>succ \<gamma>"
       using succ.IH succ.hyps by auto
     then show ?case
       using False \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close> succ
       by (metis Ord_mem_iff_lt Ord_oexp Ord_succ elts_succ insert_subset less_eq_V_def less_imp_le)
   next
     case (Limit \<mu>)
     with False \<open>1 < \<alpha>\<close> show ?case
       by (force simp: Limit_def oexp_Limit intro: elts_succ)
   qed
 qed
 
 
 lemma oexp_Limit_le:
   assumes "\<beta> < \<gamma>" "Limit \<gamma>" "Ord \<beta>" "\<alpha> > 0" shows "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
 proof -
   have "Ord \<gamma>"
     using Limit_def assms(2) by blast
   with assms show ?thesis
     using Ord_mem_iff_lt ZFC_in_HOL.Sup_upper oexp_Limit by auto
 qed
 
 proposition oexp_less:
   assumes \<beta>: "\<beta> \<in> elts \<gamma>" and "Ord \<gamma>" and \<alpha>: "\<alpha> > 1" "Ord \<alpha>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
 proof -
   obtain "\<beta> < \<gamma>" "Ord \<beta>"
     using Ord_in_Ord OrdmemD assms by auto
   have gt0: "\<alpha>\<up>\<beta> > 0"
     using \<open>Ord \<beta>\<close> \<alpha> dual_order.order_iff_strict by auto
   show ?thesis
     using \<open>Ord \<gamma>\<close> \<beta>
   proof (induction rule: Ord_induct3)
     case 0
     then show ?case
       by auto
   next
     case (succ \<delta>)
     then consider "\<beta> = \<delta>" | "\<beta> < \<delta>"
       using OrdmemD elts_succ by blast
     then show ?case
     proof cases
       case 1
       then have "(\<alpha>\<up>\<beta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
         using Ord_1 Ord_oexp \<alpha> gt0 mult_cancel_less_iff succ.hyps by metis
       then show ?thesis
         by (simp add: succ.hyps)
     next
       case 2
       then have "(\<alpha>\<up>\<delta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
         by (meson Ord_1 Ord_mem_iff_lt Ord_oexp \<open>Ord \<beta>\<close> \<alpha> gt0 less_trans mult_cancel_less_iff succ)
       with 2 show ?thesis
         using Ord_mem_iff_lt \<open>Ord \<beta>\<close> succ by auto
     qed
   next
     case (Limit \<gamma>)
     then obtain "Ord \<gamma>" "succ \<beta> < \<gamma>"
       using Limit_def Ord_in_Ord OrdmemD assms by auto
     have "\<alpha>\<up>\<beta> = (\<alpha>\<up>\<beta>) * 1"
       by simp
     also have "\<dots> < (\<alpha>\<up>\<beta>) * \<alpha>"
       using Ord_oexp \<open>Ord \<beta>\<close> assms gt0 mult_cancel_less_iff by blast
     also have "\<dots> = \<alpha>\<up>succ \<beta>"
       by (simp add: \<open>Ord \<beta>\<close>)
-    also have "\<dots> \<le> (SUP \<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)"
+    also have "\<dots> \<le> (\<Squnion>\<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)"
     proof -
       have "succ \<beta> \<in> elts \<gamma>"
         using Limit.hyps Limit.prems Limit_def by auto
       then show ?thesis
         by (simp add: ZFC_in_HOL.Sup_upper)
     qed
     finally
-    have "\<alpha>\<up>\<beta> < (SUP \<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)" .
+    have "\<alpha>\<up>\<beta> < (\<Squnion>\<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)" .
     then show ?case
       using Limit.hyps oexp_Limit \<open>\<alpha> > 1\<close> by auto
   qed
 qed
 
 corollary oexp_less_iff:
   assumes "\<alpha> > 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma> \<longleftrightarrow> \<beta> \<in> elts \<gamma> \<and> \<alpha> > 1"
 proof safe
   show "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
     if "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
   proof -
     show "\<alpha> > 1"
     proof (rule ccontr)
       assume "\<not> \<alpha> > 1"
       then consider "\<alpha>=0" | "\<alpha>=1"
         using \<open>Ord \<alpha>\<close> less_V_def mem_0_Ord by fastforce
       then show False
         by cases (use that \<open>\<alpha> > 0\<close> \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> in \<open>auto split: if_split_asm\<close>)
     qed
     show \<beta>: "\<beta> \<in> elts \<gamma>"
     proof (rule ccontr)
       assume "\<beta> \<notin> elts \<gamma>"
       then have "\<gamma> \<le> \<beta>"
         by (meson Ord_linear_le Ord_mem_iff_lt assms less_le_not_le)
       then consider "\<gamma> = \<beta>" | "\<gamma> < \<beta>"
         using less_V_def by blast
       then show False
       proof cases
         case 1
         then show ?thesis
           using that by blast
       next
         case 2
         with \<open>\<alpha> > 1\<close> have "\<alpha>\<up>\<gamma> < \<alpha>\<up>\<beta>"
           by (simp add: Ord_mem_iff_lt assms oexp_less)
         with that show ?thesis
           by auto
       qed
     qed
   qed
   show "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>" if "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
     using that by (simp add: assms oexp_less)
 qed
 
 lemma \<omega>_oexp_iff [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> \<omega>\<up>\<alpha> = \<omega>\<up>\<beta> \<longleftrightarrow> \<alpha>=\<beta>"
   by (metis Ord_\<omega> Ord_linear \<omega>_gt1 less_irrefl oexp_less)
 
 lemma Limit_oexp:
   assumes "Limit \<gamma>" "Ord \<alpha>" "\<alpha> > 1" shows "Limit (\<alpha>\<up>\<gamma>)"
   unfolding Limit_def
 proof safe
   show O\<alpha>\<gamma>: "Ord (\<alpha>\<up>\<gamma>)"
     using Limit_def Ord_oexp \<open>Limit \<gamma>\<close> assms(2) by blast
   show 0: "0 \<in> elts (\<alpha>\<up>\<gamma>)"
     using Limit_def oexp_Limit \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close> by fastforce
   have "Ord \<gamma>"
     using Limit_def \<open>Limit \<gamma>\<close> by blast
   fix x
   assume x: "x \<in> elts (\<alpha>\<up>\<gamma>)"
   with \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close>
   obtain \<beta> where "\<beta> < \<gamma>" "Ord \<beta>" "Ord x" and x\<beta>: "x \<in> elts (\<alpha>\<up>\<beta>)"
     apply (simp add: oexp_Limit split: if_split_asm)
     using Ord_in_Ord OrdmemD \<open>Ord \<gamma>\<close> O\<alpha>\<gamma> x by blast
   then have O\<alpha>\<beta>: "Ord (\<alpha>\<up>\<beta>)"
     using Ord_oexp assms(2) by blast
   have "\<beta> \<in> elts \<gamma>"
     by (simp add: Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> \<open>\<beta> < \<gamma>\<close>)
   moreover have "\<alpha> \<noteq> 0"
     using \<open>\<alpha> > 1\<close> by blast
   ultimately have \<alpha>\<beta>\<gamma>: "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
     by (simp add: Sup_upper oexp_Limit \<open>Limit \<gamma>\<close>)
   have "succ x \<le> \<alpha>\<up>\<beta>"
     by (simp add: OrdmemD O\<alpha>\<beta> \<open>Ord x\<close> succ_le_iff x\<beta>)
   then consider "succ x < \<alpha>\<up>\<beta>" | "succ x = \<alpha>\<up>\<beta>"
     using le_neq_trans by blast
   then show "succ x \<in> elts (\<alpha>\<up>\<gamma>)"
   proof cases
     case 1
     with \<alpha>\<beta>\<gamma> show ?thesis
       using O\<alpha>\<beta> Ord_mem_iff_lt \<open>Ord x\<close> by blast
   next
     case 2
     then have "succ \<beta> < \<gamma>"
       using Limit_def OrdmemD \<open>\<beta> \<in> elts \<gamma>\<close> assms(1) by auto
     have ge1: "1 \<le> \<alpha>\<up>\<beta>"
       by (metis "2" Ord_0 \<open>Ord x\<close> le_0 le_succ_iff one_V_def)
     have "succ x < succ (\<alpha>\<up>\<beta>)"
       using "2" O\<alpha>\<beta> succ_le_iff by auto
     also have "\<dots> \<le> (\<alpha>\<up>\<beta>) + (\<alpha>\<up>\<beta>)"
       using ge1 by (simp add: succ_eq_add1)
     also have "\<dots> = (\<alpha>\<up>\<beta>) * succ (succ 0)"
       by (simp add: mult_succ)
     also have "\<dots> \<le> (\<alpha>\<up>\<beta>) * \<alpha>"
       using O\<alpha>\<beta> Ord_succ assms(2) assms(3) one_V_def succ_le_iff by auto
     also have "\<dots> = \<alpha>\<up>succ \<beta>"
       by (simp add: \<open>Ord \<beta>\<close>)
     also have "\<dots> \<le> \<alpha>\<up>\<gamma>"
       by (meson Limit_def \<open>\<beta> \<in> elts \<gamma>\<close> assms dual_order.order_iff_strict oexp_less)
   finally show ?thesis
     by (simp add: "2" O\<alpha>\<beta> O\<alpha>\<gamma> Ord_mem_iff_lt)
   qed
 qed
 
 
 
 lemma oexp_mono:
   assumes \<alpha>: "Ord \<alpha>" "\<alpha> \<noteq> 0" and \<beta>: "Ord \<beta>" "\<gamma> \<sqsubseteq> \<beta>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
   using \<beta>
 proof (induction rule: Ord_induct3)
   case 0
   then show ?case
     by simp
 next
   case (succ \<beta>)
   with \<alpha> le_mult show ?case
     by (auto simp: le_TC_succ)
 next
   case (Limit \<mu>)
   then have "\<alpha>\<up>\<gamma> \<le> \<Squnion> ((\<up>) \<alpha> ` elts \<mu>)"
     using Limit.hyps Ord_less_TC_mem \<open>\<alpha> \<noteq> 0\<close> le_TC_def by (auto simp: oexp_Limit Limit_def)
   then show ?case
     using \<alpha> by (simp add: oexp_Limit Limit.hyps)
 qed
 
 lemma oexp_mono_le:
   assumes "\<gamma> \<le> \<beta>" "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
   by (simp add: assms oexp_mono vle2 vle_iff_le_Ord)
 
 lemma oexp_sup:
   assumes "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> \<squnion> \<gamma>) = \<alpha>\<up>\<beta> \<squnion> \<alpha>\<up>\<gamma>"
   by (metis Ord_linear_le assms oexp_mono_le sup.absorb2 sup.orderE)
 
 lemma oexp_Sup:
   assumes \<alpha>: "\<alpha> \<noteq> 0" "Ord \<alpha>" and X: "X \<subseteq> ON" "small X" "X \<noteq> {}" shows "\<alpha>\<up>\<Squnion> X = \<Squnion> ((\<up>) \<alpha> ` X)"
 proof (rule order_antisym)
   show "\<Squnion> ((\<up>) \<alpha> ` X) \<le> \<alpha>\<up>\<Squnion> X"
     by (metis ON_imp_Ord Ord_Sup ZFC_in_HOL.Sup_upper assms cSUP_least oexp_mono_le)
 next
   have "Ord (Sup X)"
     using Ord_Sup X by auto
   then show "\<alpha>\<up>\<Squnion> X \<le> \<Squnion> ((\<up>) \<alpha> ` X)"
   proof (cases rule: Ord_cases)
     case 0
     then show ?thesis
       using X dual_order.antisym by fastforce
   next
     case (succ \<beta>)
     then show ?thesis
       using ZFC_in_HOL.Sup_upper X succ_in_Sup_Ord by auto
   next
     case limit
     show ?thesis
     proof (clarsimp simp: assms oexp_Limit limit)
       fix x y z
       assume x: "x \<in> elts (\<alpha> \<up> y)" and "z \<in> X" "y \<in> elts z"
       then have "\<alpha> \<up> y \<le> \<alpha> \<up> z"
         by (meson ON_imp_Ord Ord_in_Ord OrdmemD \<alpha> \<open>X \<subseteq> ON\<close> le_less oexp_mono_le)
       with x have "x \<in> elts (\<alpha> \<up> z)" by blast
       then show "\<exists>u\<in>X. x \<in> elts (\<alpha> \<up> u)"
         using \<open>z \<in> X\<close> by blast
     qed
   qed
 qed
 
 
 lemma omega_le_Limit:
   assumes "Limit \<mu>" shows "\<omega> \<le> \<mu>"
 proof
   fix \<rho>
   assume "\<rho> \<in> elts \<omega>"
   then obtain n where "\<rho> = ord_of_nat n"
     using elts_\<omega> by auto
   have "ord_of_nat n \<in> elts \<mu>"
     by (induction n) (use Limit_def assms in auto)
   then show "\<rho> \<in> elts \<mu>"
     using \<open>\<rho> = ord_of_nat n\<close> by auto
 qed
 
 lemma finite_omega_power [simp]:
   assumes "1 < n" "n \<in> elts \<omega>" shows "n\<up>\<omega> = \<omega>"
 proof (rule order_antisym)
   have "\<Squnion> ((\<up>) (ord_of_nat k) ` elts \<omega>) \<le> \<omega>" for k
   proof (induction k)
     case 0
     then show ?case
       by auto
   next
     case (Suc k)
     then show ?case
       by (metis Ord_\<omega> OrdmemD Sup_eq_0_iff ZFC_in_HOL.SUP_le_iff le_0 le_less omega_closed_oexp ord_of_nat_\<omega>)
   qed
   then show "n\<up>\<omega> \<le> \<omega>"
     using assms
     by (simp add: elts_\<omega> oexp_Limit) metis
   show "\<omega> \<le> n\<up>\<omega>"
     using Ord_in_Ord assms le_oexp' by blast
 qed
 
 
 proposition oexp_add:
   assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> + \<gamma>) = \<alpha>\<up>\<beta> * \<alpha>\<up>\<gamma>"
 proof (cases \<open>\<alpha> = 0\<close>)
   case True
   then show ?thesis
     using assms by simp
 next
   case False
   show ?thesis
     using \<open>Ord \<gamma>\<close>
   proof (induction rule: Ord_induct3)
     case 0
     then show ?case
       by auto
   next
     case (succ \<xi>)
     then show ?case
       using \<open>Ord \<beta>\<close> by (auto simp: plus_V_succ_right mult.assoc)
   next
     case (Limit \<mu>)
-    have "\<alpha>\<up>(\<beta> + (SUP \<xi>\<in>elts \<mu>. \<xi>)) = (SUP \<xi>\<in>elts (\<beta> + \<mu>). \<alpha>\<up>\<xi>)"
+    have "\<alpha>\<up>(\<beta> + (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)) = (\<Squnion>\<xi>\<in>elts (\<beta> + \<mu>). \<alpha>\<up>\<xi>)"
       by (simp add: Limit.hyps oexp_Limit assms False)
-    also have "\<dots> = (SUP \<xi> \<in> {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. \<alpha>\<up>(\<beta> + \<xi>))"
+    also have "\<dots> = (\<Squnion>\<xi> \<in> {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. \<alpha>\<up>(\<beta> + \<xi>))"
     proof (rule Sup_eq_Sup)
       show "(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>} \<subseteq> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
         using Limit.hyps Limit_def Ord_mem_iff_lt imageI by blast
       fix x
       assume "x \<in> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
       then obtain \<xi> where \<xi>: "\<xi> \<in> elts (\<beta> + \<mu>)" and x: "x = \<alpha>\<up>\<xi>"
         by auto
       have "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
       proof (rule mem_plus_V_E [OF \<xi>])
         assume "\<xi> \<in> elts \<beta>"
         then have "\<alpha>\<up>\<xi> \<le> \<alpha>\<up>\<beta>"
           by (meson arg_subset_TC assms False le_TC_def less_TC_def oexp_mono vsubsetD)
         with zero_less_Limit [OF \<open>Limit \<mu>\<close>]
         show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
           by force
       next
         fix \<delta>
         assume "\<delta> \<in> elts \<mu>" and "\<xi> = \<beta> + \<delta>"
         have "Ord \<delta>"
           using Limit.hyps Limit_def Ord_in_Ord \<open>\<delta> \<in> elts \<mu>\<close> by blast
         moreover have "\<delta> < \<mu>"
           using Limit.hyps Limit_def OrdmemD \<open>\<delta> \<in> elts \<mu>\<close> by auto
         ultimately show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
           using \<open>\<xi> = \<beta> + \<delta>\<close> by blast
       qed
       then show "\<exists>y\<in>(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. x \<le> y"
         using x by auto
     qed auto
-    also have "\<dots> = (SUP \<xi>\<in>elts \<mu>. \<alpha>\<up>(\<beta> + \<xi>))"
+    also have "\<dots> = (\<Squnion>\<xi>\<in>elts \<mu>. \<alpha>\<up>(\<beta> + \<xi>))"
       using \<open>Limit \<mu>\<close>
       by (simp add: Ord_Collect_lt Limit_def)
-    also have "\<dots> = (SUP \<xi>\<in>elts \<mu>. \<alpha>\<up>\<beta> * \<alpha>\<up>\<xi>)"
+    also have "\<dots> = (\<Squnion>\<xi>\<in>elts \<mu>. \<alpha>\<up>\<beta> * \<alpha>\<up>\<xi>)"
       using Limit.IH by auto
-    also have "\<dots> = \<alpha>\<up>\<beta> * \<alpha>\<up>(SUP \<xi>\<in>elts \<mu>. \<xi>)"
+    also have "\<dots> = \<alpha>\<up>\<beta> * \<alpha>\<up>(\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)"
       using \<open>\<alpha> \<noteq> 0\<close> Limit.hyps
       by (simp add: image_image oexp_Limit mult_Sup_distrib)
     finally show ?case .
   qed
 qed
 
 proposition oexp_mult:
   assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> * \<gamma>) = (\<alpha>\<up>\<beta>)\<up>\<gamma>"
 proof (cases "\<alpha> = 0 \<or> \<beta> = 0")
   case True
   then show ?thesis
     by (auto simp: \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close>)
 next
   case False
   show ?thesis
     using \<open>Ord \<gamma>\<close>
   proof (induction rule: Ord_induct3)
     case 0
     then show ?case
       by auto
   next
     case succ
     then show ?case
       using assms by (auto simp: mult_succ oexp_add)
   next
     case (Limit \<mu>)
     have Lim: "Limit (\<Squnion> ((*) \<beta> ` elts \<mu>))"
       unfolding Limit_def
     proof (intro conjI allI impI)
       show "Ord (\<Squnion> ((*) \<beta> ` elts \<mu>))"
         using Limit.hyps Limit_def Ord_in_Ord \<open>Ord \<beta>\<close> by (auto intro: Ord_Sup)
       have "succ 0 \<in> elts \<mu>"
         using Limit.hyps Limit_def by blast
       then show "0 \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
         using False \<open>Ord \<beta>\<close> mem_0_Ord by force
       show "succ y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
         if "y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))" for y
         using that False Limit.hyps
         apply (clarsimp simp: Limit_def)
         by (metis Ord_in_Ord Ord_linear Ord_mem_iff_lt Ord_mult Ord_succ assms(2) less_V_def mult_cancellation mult_succ not_add_mem_right succ_le_iff succ_ne_self)
     qed
-    have "\<alpha>\<up>(\<beta> * (SUP \<xi>\<in>elts \<mu>. \<xi>)) = \<alpha>\<up>\<Squnion> ((*) \<beta> ` elts \<mu>)"
+    have "\<alpha>\<up>(\<beta> * (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)) = \<alpha>\<up>\<Squnion> ((*) \<beta> ` elts \<mu>)"
       by (simp add: mult_Sup_distrib)
     also have "\<dots> = \<Squnion> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
       using False Lim oexp_Limit by fastforce
-    also have "\<dots> = (SUP x\<in>elts \<mu>. \<alpha>\<up>(\<beta> * x))"
+    also have "\<dots> = (\<Squnion>x\<in>elts \<mu>. \<alpha>\<up>(\<beta> * x))"
     proof (rule Sup_eq_Sup)
       show "(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu> \<subseteq> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
         using \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
         apply clarsimp
         by (metis Limit_def elts_succ imageI insertI1 mem_0_Ord mult_add_mem_0)
       show "\<exists>y\<in>(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu>. x \<le> y"
         if "x \<in> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))" for x
         using that \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
         by clarsimp (metis Limit_def Ord_in_Ord Ord_mult VWO_TC_le mem_imp_VWO oexp_mono)
     qed auto
-    also have "\<dots> = \<Squnion> ((\<up>) (\<alpha>\<up>\<beta>) ` elts (SUP \<xi>\<in>elts \<mu>. \<xi>))"
+    also have "\<dots> = \<Squnion> ((\<up>) (\<alpha>\<up>\<beta>) ` elts (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>))"
       using Limit.IH Limit.hyps by auto
-    also have "\<dots> = (\<alpha>\<up>\<beta>)\<up>(SUP \<xi>\<in>elts \<mu>. \<xi>)"
+    also have "\<dots> = (\<alpha>\<up>\<beta>)\<up>(\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)"
       using False Limit.hyps oexp_Limit \<open>Ord \<beta>\<close> by auto
     finally show ?case .
   qed
 qed
 
 lemma Limit_omega_oexp:
   assumes "Ord \<delta>" "\<delta> \<noteq> 0"
   shows "Limit (\<omega>\<up>\<delta>)"
   using assms
 proof (cases \<delta> rule: Ord_cases)
   case 0
   then show ?thesis
     using assms(2) by blast
 next
   case (succ l)
   have *: "succ \<beta> \<in> elts (\<omega>\<up>l * n + \<omega>\<up>l)"
     if n: "n \<in> elts \<omega>" and \<beta>: "\<beta> \<in> elts (\<omega>\<up>l * n)" for n \<beta>
   proof -
     obtain "Ord n" "Ord \<beta>"
       by (meson Ord_\<omega> Ord_in_Ord Ord_mult Ord_oexp \<beta> n succ(1))
     obtain oo: "Ord (\<omega>\<up>l)" "Ord (\<omega>\<up>l * n)"
       by (simp add: \<open>Ord n\<close> succ(1))
     moreover have f4: "\<beta> < \<omega>\<up>l * n"
       using oo Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>\<beta> \<in> elts (\<omega>\<up>l * n)\<close> by blast
     moreover have f5: "Ord (succ \<beta>)"
       using \<open>Ord \<beta>\<close> by blast
     moreover have "\<omega>\<up>l \<noteq> 0"
       using oexp_eq_0_iff omega_nonzero succ(1) by blast
     ultimately show ?thesis
       by (metis add_less_cancel_left Ord_\<omega> Ord_add Ord_mem_iff_lt OrdmemD \<open>Ord \<beta>\<close> add.right_neutral dual_order.strict_trans2 oexp_gt_0_iff succ(1) succ_le_iff zero_in_omega)
   qed
   show ?thesis
     using succ
     apply (clarsimp simp: Limit_def mem_0_Ord)
     apply (simp add: mult_Limit)
     by (metis * mult_succ succ_in_omega)
 next
   case limit
   then show ?thesis
     by (metis Limit_oexp Ord_\<omega> OrdmemD one_V_def succ_in_omega zero_in_omega)
 qed
 
 lemma oexp_mult_commute:
   fixes j::nat
   assumes "Ord \<alpha>"
   shows "(\<alpha> \<up> j) * \<alpha> = \<alpha> * (\<alpha> \<up> j)"
 proof -
   have "(\<alpha> \<up> j) * \<alpha> = \<alpha> \<up> (1 + ord_of_nat j)"
     by (simp add: one_V_def)
   also have "... = \<alpha> * (\<alpha> \<up> j)"
     by (simp add: assms oexp_add)
   finally show ?thesis .
 qed
 
-lemma oexp_\<omega>_Limit: "Limit \<beta> \<Longrightarrow> \<omega>\<up>\<beta> = (SUP \<xi> \<in> elts \<beta>. \<omega>\<up>\<xi>)"
+lemma oexp_\<omega>_Limit: "Limit \<beta> \<Longrightarrow> \<omega>\<up>\<beta> = (\<Squnion>\<xi> \<in> elts \<beta>. \<omega>\<up>\<xi>)"
   by (simp add: oexp_Limit)
 
 lemma \<omega>_power_succ_gtr: "Ord \<alpha> \<Longrightarrow> \<omega> \<up> \<alpha> * ord_of_nat n < \<omega> \<up> succ \<alpha>"
   by (simp add: OrdmemD)
 
 lemma countable_oexp:
   assumes \<nu>: "\<alpha> \<in> elts \<omega>1" 
   shows "\<omega> \<up> \<alpha> \<in> elts \<omega>1"
 proof -
   have "Ord \<alpha>"
     using Ord_\<omega>1 Ord_in_Ord assms by blast
   then show ?thesis
     using assms
   proof (induction rule: Ord_induct3)
     case 0
     then show ?case
       by (simp add: Ord_mem_iff_lt)
   next
     case (succ \<alpha>)
     then have "countable (elts (\<omega> \<up> \<alpha> * \<omega>))"
       by (simp add: succ_in_Limit_iff countable_mult less_\<omega>1_imp_countable)
     then show ?case
       using Ord_mem_iff_lt countable_iff_less_\<omega>1 succ.hyps by auto
   next
     case (Limit \<alpha>)
     with Ord_\<omega>1 have "countable (\<Union>\<beta>\<in>elts \<alpha>. elts (\<omega> \<up> \<beta>))" "Ord (\<omega> \<up> \<Squnion> (elts \<alpha>))"
       by (force simp: Limit_def intro: Ord_trans less_\<omega>1_imp_countable)+
     then have "\<omega> \<up> \<Squnion> (elts \<alpha>) < \<omega>1"
       using Limit.hyps countable_iff_less_\<omega>1 oexp_Limit by fastforce
     then show ?case
       using Limit.hyps Limit_def Ord_mem_iff_lt by auto
   qed
 qed
 
 end
diff --git a/thys/ZFC_in_HOL/ZFC_Cardinals.thy b/thys/ZFC_in_HOL/ZFC_Cardinals.thy
--- a/thys/ZFC_in_HOL/ZFC_Cardinals.thy
+++ b/thys/ZFC_in_HOL/ZFC_Cardinals.thy
@@ -1,2541 +1,2538 @@
 section \<open>Cartesian products, Disjoint Sums, Ranks, Cardinals\<close>
 
 theory ZFC_Cardinals
   imports ZFC_in_HOL
 
 begin
 
 declare [[coercion_enabled]]
 declare [[coercion "ord_of_nat :: nat \<Rightarrow> V"]]
 
 subsection \<open>Ordered Pairs\<close>
 
 lemma singleton_eq_iff [iff]: "set {a} = set {b} \<longleftrightarrow> a=b"
   by simp
 
 lemma doubleton_eq_iff: "set {a,b} = set {c,d} \<longleftrightarrow> (a=c \<and> b=d) \<or> (a=d \<and> b=c)"
   by (simp add: Set.doubleton_eq_iff)
 
 definition vpair :: "V \<Rightarrow> V \<Rightarrow> V"
   where "vpair a b = set {set {a},set {a,b}}"
 
 definition vfst :: "V \<Rightarrow> V"
   where "vfst p \<equiv> THE x. \<exists>y. p = vpair x y"
 
 definition vsnd :: "V \<Rightarrow> V"
   where "vsnd p \<equiv> THE y. \<exists>x. p = vpair x y"
 
 definition vsplit :: "[[V, V] \<Rightarrow> 'a, V] \<Rightarrow> 'a::{}"  \<comment> \<open>for pattern-matching\<close>
   where "vsplit c \<equiv> \<lambda>p. c (vfst p) (vsnd p)"
 
 nonterminal Vs
 syntax (ASCII)
   "_Tuple"    :: "[V, Vs] \<Rightarrow> V"              ("<(_,/ _)>")
   "_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn"   ("<_,/ _>")
 syntax
   ""          :: "V \<Rightarrow> Vs"                    ("_")
   "_Enum"     :: "[V, Vs] \<Rightarrow> Vs"             ("_,/ _")
   "_Tuple"    :: "[V, Vs] \<Rightarrow> V"              ("\<langle>(_,/ _)\<rangle>")
   "_hpattern" :: "[pttrn, patterns] \<Rightarrow> pttrn"   ("\<langle>_,/ _\<rangle>")
 translations
   "<x, y, z>"    \<rightleftharpoons> "<x, <y, z>>"
   "<x, y>"       \<rightleftharpoons> "CONST vpair x y"
   "<x, y, z>"    \<rightleftharpoons> "<x, <y, z>>"
   "\<lambda><x,y,zs>. b" \<rightleftharpoons> "CONST vsplit(\<lambda>x <y,zs>. b)"
   "\<lambda><x,y>. b"    \<rightleftharpoons> "CONST vsplit(\<lambda>x y. b)"
 
 
 lemma vpair_def': "vpair a b = set {set {a,a},set {a,b}}"
   by (simp add: vpair_def)
 
 lemma vpair_iff [simp]: "vpair a b = vpair a' b' \<longleftrightarrow> a=a' \<and> b=b'"
   unfolding vpair_def' doubleton_eq_iff by auto
 
 lemmas vpair_inject = vpair_iff [THEN iffD1, THEN conjE, elim!]
 
 lemma vfst_conv [simp]: "vfst \<langle>a,b\<rangle> = a"
   by (simp add: vfst_def)
 
 lemma vsnd_conv [simp]: "vsnd \<langle>a,b\<rangle> = b"
   by (simp add: vsnd_def)
 
 lemma vsplit [simp]: "vsplit c \<langle>a,b\<rangle> = c a b"
   by (simp add: vsplit_def)
 
 lemma vpair_neq_fst: "\<langle>a,b\<rangle> \<noteq> a"
   by (metis elts_of_set insertI1 mem_not_sym small_upair vpair_def')
 
 lemma vpair_neq_snd: "\<langle>a,b\<rangle> \<noteq> b"
   by (metis elts_of_set insertI1 mem_not_sym small_upair subsetD subset_insertI vpair_def')
 
 lemma vpair_nonzero [simp]: "\<langle>x,y\<rangle> \<noteq> 0"
   by (metis elts_0 elts_of_set empty_not_insert small_upair vpair_def)
 
 lemma zero_notin_vpair: "0 \<notin> elts \<langle>x,y\<rangle>"
   by (auto simp: vpair_def)
 
 lemma inj_on_vpair [simp]: "inj_on (\<lambda>(x, y). \<langle>x, y\<rangle>) A"
   by (auto simp: inj_on_def)
 
 
 subsection \<open>Generalized Cartesian product\<close>
 
 definition VSigma :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
   where "VSigma A B \<equiv> set(\<Union>x \<in> elts A. \<Union>y \<in> elts (B x). {\<langle>x,y\<rangle>})"
 
 abbreviation vtimes where "vtimes A B \<equiv> VSigma A (\<lambda>x. B)"
 
 definition pairs :: "V \<Rightarrow> (V * V)set"
   where "pairs r \<equiv> {(x,y). \<langle>x,y\<rangle> \<in> elts r} "
 
 lemma pairs_iff_elts: "(x,y) \<in> pairs z \<longleftrightarrow> \<langle>x,y\<rangle> \<in> elts z"
   by (simp add: pairs_def)
 
 lemma VSigma_iff [simp]: "\<langle>a,b\<rangle> \<in> elts (VSigma A B) \<longleftrightarrow> a \<in> elts A \<and> b \<in> elts (B a)"
   by (auto simp: VSigma_def UNION_singleton_eq_range)
 
 lemma VSigmaI [intro!]: "\<lbrakk> a \<in> elts A;  b \<in> elts (B a)\<rbrakk>  \<Longrightarrow> \<langle>a,b\<rangle> \<in> elts (VSigma A B)"
   by simp
 
 lemmas VSigmaD1 = VSigma_iff [THEN iffD1, THEN conjunct1]
 lemmas VSigmaD2 = VSigma_iff [THEN iffD1, THEN conjunct2]
 
 text \<open>The general elimination rule\<close>
 lemma VSigmaE [elim!]:
   assumes "c \<in> elts (VSigma A B)"
   obtains x y where "x \<in> elts A" "y \<in> elts (B x)" "c=\<langle>x,y\<rangle>"
   using assms by (auto simp: VSigma_def split: if_split_asm)
 
 lemma VSigmaE2 [elim!]:
   assumes "\<langle>a,b\<rangle> \<in> elts (VSigma A B)" obtains "a \<in> elts A" and "b \<in> elts (B a)"
   using assms  by auto
 
 lemma VSigma_empty1 [simp]: "VSigma 0 B = 0"
   by auto
 
 lemma times_iff [simp]: "\<langle>a,b\<rangle> \<in> elts (vtimes A B) \<longleftrightarrow> a \<in> elts A \<and> b \<in> elts B"
   by simp
 
 lemma timesI [intro!]: "\<lbrakk>a \<in> elts A;  b \<in> elts B\<rbrakk>  \<Longrightarrow> \<langle>a,b\<rangle> \<in> elts (vtimes A B)"
   by simp
 
 lemma times_empty2 [simp]: "vtimes A 0 = 0"
   using elts_0 by blast
 
 lemma times_empty_iff: "VSigma A B = 0 \<longleftrightarrow> A=0 \<or> (\<forall>x \<in> elts A. B x = 0)"
   by (metis VSigmaE VSigmaI elts_0 empty_iff trad_foundation)
 
 lemma elts_VSigma: "elts (VSigma a b) = (\<lambda>(x,y). vpair x y) ` Sigma (elts a) (\<lambda>x. elts (b x))"
   by auto
 
 lemma small_Times [simp]:
   assumes "small A" "small B" 
   shows "small (A \<times> B)"
 proof -
   obtain f a g b where "inj_on f A" "inj_on g B" and f: "f ` A = elts a" and g: "g ` B = elts b"
     using assms by (auto simp: small_def)
   define h where "h \<equiv> \<lambda>(x,y). \<langle>f x, g y\<rangle>"
   show ?thesis
     unfolding small_def
   proof (intro exI conjI)
     show "inj_on h (A \<times> B)"
       using \<open>inj_on f A\<close> \<open>inj_on g B\<close> by (simp add: h_def inj_on_def)
     have "h ` (A \<times> B) = elts (vtimes a b)"
       using f g by (fastforce simp: h_def image_iff split: prod.split)
     then show "h ` (A \<times> B) \<in> range elts"
       by blast
   qed
 qed
 
 
 subsection \<open>Disjoint Sum\<close>
 
 definition vsum :: "V \<Rightarrow> V \<Rightarrow> V" (infixl "\<Uplus>" 65) where
  "A \<Uplus> B \<equiv> (VSigma (set {0}) (\<lambda>x. A)) \<squnion> (VSigma (set {1}) (\<lambda>x. B))"
 
 definition Inl :: "V\<Rightarrow>V" where
      "Inl a \<equiv> \<langle>0,a\<rangle>"
 
 definition Inr :: "V\<Rightarrow>V" where
      "Inr b \<equiv> \<langle>1,b\<rangle>"
 
 lemmas sum_defs = vsum_def Inl_def Inr_def
 
 lemma Inl_nonzero [simp]:"Inl x \<noteq> 0"
   by (metis Inl_def vpair_nonzero)
 
 lemma Inr_nonzero [simp]:"Inr x \<noteq> 0"
   by (metis Inr_def vpair_nonzero)
 
 subsubsection\<open>Equivalences for the injections and an elimination rule\<close>
 
 lemma Inl_in_sum_iff [iff]: "Inl a \<in> elts (A \<Uplus> B) \<longleftrightarrow> a \<in> elts A"
   by (auto simp: sum_defs)
 
 lemma Inr_in_sum_iff [iff]: "Inr b \<in> elts (A \<Uplus> B) \<longleftrightarrow> b \<in> elts B"
   by (auto simp: sum_defs)
 
 lemma sumE [elim!]:
   assumes u: "u \<in> elts (A \<Uplus> B)"
   obtains x where "x \<in> elts A" "u=Inl x" | y where "y \<in> elts B" "u=Inr y" using u
   by (auto simp: sum_defs)
 
 subsubsection \<open>Injection and freeness equivalences, for rewriting\<close>
 
 lemma Inl_iff [iff]: "Inl a=Inl b \<longleftrightarrow> a=b"
   by (simp add: sum_defs)
 
 lemma Inr_iff [iff]: "Inr a=Inr b \<longleftrightarrow> a=b"
   by (simp add: sum_defs)
 
 lemma inj_on_Inl [simp]: "inj_on Inl A"
   by (simp add: inj_on_def)
 
 lemma inj_on_Inr [simp]: "inj_on Inr A"
   by (simp add: inj_on_def)
 
 lemma Inl_Inr_iff [iff]: "Inl a=Inr b \<longleftrightarrow> False"
   by (simp add: sum_defs)
 
 lemma Inr_Inl_iff [iff]: "Inr b=Inl a \<longleftrightarrow> False"
   by (simp add: sum_defs)
 
 lemma sum_empty [simp]: "0 \<Uplus> 0 = 0"
   by auto
 
 lemma elts_vsum: "elts (a \<Uplus> b) = Inl ` (elts a) \<union> Inr ` (elts b)"
   by auto
 
 lemma sum_iff: "u \<in> elts (A \<Uplus> B) \<longleftrightarrow> (\<exists>x. x \<in> elts A \<and> u=Inl x) \<or> (\<exists>y. y \<in> elts B \<and> u=Inr y)"
   by blast
 
 lemma sum_subset_iff: "A\<Uplus>B \<le> C\<Uplus>D \<longleftrightarrow> A\<le>C \<and> B\<le>D"
   by (auto simp: less_eq_V_def)
 
 lemma sum_equal_iff:
   fixes A :: V shows "A\<Uplus>B = C\<Uplus>D \<longleftrightarrow> A=C \<and> B=D"
   by (simp add: eq_iff sum_subset_iff)
 
 definition is_sum :: "V \<Rightarrow> bool"
   where "is_sum z = (\<exists>x. z = Inl x \<or> z = Inr x)"
 
 definition sum_case  :: "(V \<Rightarrow> 'a) \<Rightarrow> (V \<Rightarrow> 'a) \<Rightarrow> V \<Rightarrow> 'a"
   where
   "sum_case f g a \<equiv>
     THE z. (\<forall>x. a = Inl x \<longrightarrow> z = f x) \<and> (\<forall>y. a = Inr y \<longrightarrow> z = g y) \<and> (\<not> is_sum a \<longrightarrow> z = undefined)"
 
 lemma sum_case_Inl [simp]: "sum_case f g (Inl x) = f x"
   by (simp add: sum_case_def is_sum_def)
 
 lemma sum_case_Inr [simp]: "sum_case f g (Inr y) = g y"
   by (simp add: sum_case_def is_sum_def)
 
 lemma sum_case_non [simp]: "\<not> is_sum a \<Longrightarrow> sum_case f g a = undefined"
   by (simp add: sum_case_def is_sum_def)
 
 lemma is_sum_cases: "(\<exists>x. z = Inl x \<or> z = Inr x) \<or> \<not> is_sum z"
   by (auto simp: is_sum_def)
 
 lemma sum_case_split:
   "P (sum_case f g a) \<longleftrightarrow> (\<forall>x. a = Inl x \<longrightarrow> P(f x)) \<and> (\<forall>y. a = Inr y \<longrightarrow> P(g y)) \<and> (\<not> is_sum a \<longrightarrow> P undefined)"
   by (cases "is_sum a") (auto simp: is_sum_def)
 
 lemma sum_case_split_asm:
   "P (sum_case f g a) \<longleftrightarrow> \<not> ((\<exists>x. a = Inl x \<and> \<not> P(f x)) \<or> (\<exists>y. a = Inr y \<and> \<not> P(g y)) \<or> (\<not> is_sum a \<and> \<not> P undefined))"
   by (auto simp: sum_case_split)
 
 subsubsection \<open>Applications of disjoint sums and pairs: general union theorems for small sets\<close>
 
 lemma small_Un:
   assumes X: "small X" and Y: "small Y"
   shows "small (X \<union> Y)"
 proof -
   obtain f g :: "'a\<Rightarrow>V" where f: "inj_on f X" and g: "inj_on g Y" 
     by (meson assms small_def)
   define h where "h \<equiv> \<lambda>z. if z \<in> X then Inl (f z) else Inr (g z)"
   show ?thesis
     unfolding small_def
   proof (intro exI conjI)
     show "inj_on h (X \<union> Y)"
       using f g by (auto simp add: inj_on_def h_def)
     show "h ` (X \<union> Y) \<in> range elts"
       by (metis X Y image_Un replacement small_iff_range small_sup_iff)
   qed
 qed
 
 lemma small_UN [simp,intro]:
   assumes X: "small X" and B: "\<And>x. x \<in> X \<Longrightarrow> small (B x)"
   shows "small (\<Union>x\<in>X. B x)"
 proof -
   obtain f :: "'a\<Rightarrow>V" where f: "inj_on f X" 
     by (meson assms small_def)
   have "\<exists>g. inj_on g (B x) \<and> g ` (B x) \<in> range elts" if "x \<in> X" for x
     using B small_def that by auto
   then obtain g::"'a \<Rightarrow> 'b \<Rightarrow> V" where g: "\<And>x. x \<in> X \<Longrightarrow> inj_on (g x) (B x)" 
     by metis
   define \<phi> where "\<phi> \<equiv> \<lambda>y. @x. x \<in> X \<and> y \<in> B x"
   have \<phi>: "\<phi> y \<in> X \<and> y \<in> B (\<phi> y)" if "y \<in> (\<Union>x\<in>X. B x)" for y
     unfolding \<phi>_def by (metis (mono_tags, lifting) UN_E someI that)
   define h where "h \<equiv> \<lambda>y. \<langle>f (\<phi> y), g (\<phi> y) y\<rangle>"
   show ?thesis
     unfolding small_def
   proof (intro exI conjI)
     show "inj_on h (\<Union> (B ` X))"
       using f g \<phi> unfolding h_def inj_on_def by (metis vpair_inject)
   have "small (h ` \<Union> (B ` X))"
     by (simp add: B X image_UN)
   then show "h ` \<Union> (B ` X) \<in> range elts"
     using small_iff_range by blast
   qed
 qed
 
 lemma small_Union [simp,intro]:
   assumes "\<A> \<subseteq> Collect small" "small \<A>"
   shows "small (\<Union> \<A>)"
   using small_UN [of \<A> "\<lambda>x. x"] assms by (simp add: subset_iff)
 
 subsection\<open>Generalised function space and lambda\<close>
 
 definition VLambda :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
   where "VLambda A b \<equiv> set ((\<lambda>x. \<langle>x,b x\<rangle>) ` elts A)"
 
 definition app :: "[V,V] \<Rightarrow> V"
   where "app f x \<equiv> THE y. \<langle>x,y\<rangle> \<in> elts f"
 
 lemma beta [simp]:
   assumes "x \<in> elts A"
   shows "app (VLambda A b) x = b x"
   using assms by (auto simp: VLambda_def app_def)
 
 definition VPi :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
   where "VPi A B \<equiv> set {f \<in> elts (VPow(VSigma A B)). elts A \<le> Domain (pairs f) \<and> single_valued (pairs f)}"
 
 lemma VPi_I:
   assumes "\<And>x. x \<in> elts A \<Longrightarrow> b x \<in> elts (B x)"
   shows "VLambda A b \<in> elts (VPi A B)"
   proof (clarsimp simp: VPi_def, intro conjI impI)
   show "VLambda A b \<le> VSigma A B"
     by (auto simp: assms VLambda_def split: if_split_asm)
   show "elts A \<subseteq> Domain (pairs (VLambda A b))"
     by (force simp: VLambda_def pairs_iff_elts)
   show "single_valued (pairs (VLambda A b))"
     by (auto simp: VLambda_def single_valued_def pairs_iff_elts)
   show "small {f. f \<le> VSigma A B \<and> elts A \<subseteq> Domain (pairs f) \<and> single_valued (pairs f)}"
     by (metis (mono_tags, lifting) down VPow_iff mem_Collect_eq subsetI)
 qed
 
 lemma apply_pair:
   assumes f: "f \<in> elts (VPi A B)" and x: "x \<in> elts A"
   shows "\<langle>x, app f x\<rangle> \<in> elts f"
 proof -
   have "x \<in> Domain (pairs f)"
     by (metis (no_types, lifting) VPi_def assms elts_of_set empty_iff mem_Collect_eq subsetD)
   then obtain y where y: "\<langle>x,y\<rangle> \<in> elts f"
     using pairs_iff_elts by auto
   show ?thesis
     unfolding app_def
   proof (rule theI)
     show "\<langle>x, y\<rangle> \<in> elts f"
       by (rule y)
     show "z = y" if "\<langle>x, z\<rangle> \<in> elts f" for z
       using f unfolding VPi_def
       by (metis (mono_tags, lifting) that elts_of_set empty_iff mem_Collect_eq pairs_iff_elts single_valued_def y)
   qed
 qed
 
 lemma VPi_D:
   assumes f: "f \<in> elts (VPi A B)" and x: "x \<in> elts A"
   shows "app f x \<in> elts (B x)"
 proof -
   have "f \<le> VSigma A B"
     by (metis (no_types, lifting) VPi_def elts_of_set empty_iff f VPow_iff mem_Collect_eq)
   then show ?thesis
     using apply_pair [OF assms] by blast
 qed
 
 lemma VPi_memberD:
   assumes f: "f \<in> elts (VPi A B)" and p: "p \<in> elts f"
   obtains x where "x \<in> elts A" "p = \<langle>x, app f x\<rangle>"
 proof -
   have "f \<le> VSigma A B"
     by (metis (no_types, lifting) VPi_def elts_of_set empty_iff f VPow_iff mem_Collect_eq)
   then obtain x y where "p = \<langle>x,y\<rangle>" "x \<in> elts A"
     using p by blast
   then have "y = app f x"
     by (metis (no_types, lifting) VPi_def apply_pair elts_of_set equals0D f mem_Collect_eq p pairs_iff_elts single_valuedD)
   then show thesis
     using \<open>p = \<langle>x, y\<rangle>\<close> \<open>x \<in> elts A\<close> that by blast
 qed
 
 lemma fun_ext:
   assumes "f \<in> elts (VPi A B)" "g \<in> elts (VPi A B)" "\<And>x. x \<in> elts A \<Longrightarrow> app f x = app g x"
   shows "f = g"
   by (metis VPi_memberD V_equalityI apply_pair assms)
 
 lemma eta[simp]:
   assumes "f \<in> elts (VPi A B)"
   shows "VLambda A ((app)f) = f"
   proof (rule fun_ext [OF _ assms])
   show "VLambda A (app f) \<in> elts (VPi A B)"
     using VPi_D VPi_I assms by auto
 qed auto
 
 
 lemma fst_pairs_VLambda: "fst ` pairs (VLambda A f) = elts A"
   by (force simp: VLambda_def pairs_def)
 
 lemma snd_pairs_VLambda: "snd ` pairs (VLambda A f) = f ` elts A"
   by (force simp: VLambda_def pairs_def)
 
 lemma VLambda_eq_D1: "VLambda A f = VLambda B g \<Longrightarrow> A = B"
   by (metis ZFC_in_HOL.ext fst_pairs_VLambda)
 
 lemma VLambda_eq_D2: "\<lbrakk>VLambda A f = VLambda A g; x \<in> elts A\<rbrakk> \<Longrightarrow> f x = g x"
   by (metis beta)
 
 
 subsection\<open>Transitive closure of a set\<close>
 
 definition TC :: "V\<Rightarrow>V"
   where "TC \<equiv> transrec (\<lambda>f x. x \<squnion> \<Squnion> (f ` elts x))"
 
 lemma TC: "TC a = a \<squnion> \<Squnion> (TC ` elts a)"
   by (metis (no_types, lifting) SUP_cong TC_def restrict_apply' transrec)
 
 lemma TC_0 [simp]: "TC 0 = 0"
   by (metis TC ZFC_in_HOL.Sup_empty elts_0 image_is_empty sup_V_0_left)
 
 lemma arg_subset_TC: "a \<le> TC a"
   by (metis (no_types) TC sup_ge1)
 
 lemma Transset_TC: "Transset(TC a)"
 proof (induction a rule: eps_induct)
   case (step x)
   have 1: "v \<in> elts (TC x)" if "v \<in> elts u" "u \<in> elts x" for u v
     using that unfolding TC [of x]
     using arg_subset_TC by fastforce
   have 2: "v \<in> elts (TC x)" if "v \<in> elts u" "\<exists>x\<in>elts x. u \<in> elts (TC x)" for u v
     using that step unfolding TC [of x] Transset_def by auto
   show ?case
     unfolding Transset_def
     by (subst TC) (force intro: 1 2)
 qed
 
 lemma TC_least: "\<lbrakk>Transset x;  a\<le>x\<rbrakk> \<Longrightarrow> TC a \<le> x"
 proof (induction a rule: eps_induct)
   case (step y)
   show ?case
   proof (cases "y=0")
     case True
     then show ?thesis
       by auto
   next
     case False
     have "\<Squnion> (TC ` elts y) \<le> x"
     proof (rule cSup_least)
       show "TC ` elts y \<noteq> {}"
         using False by auto
       show "z \<le> x" if "z \<in> TC ` elts y" for z
         using that by (metis Transset_def image_iff step.IH step.prems vsubsetD)
     qed
     then show ?thesis
       by (simp add: step TC [of y])
   qed
 qed
 
 definition less_TC (infix "\<sqsubset>" 50)
   where "x \<sqsubset> y \<equiv> x \<in> elts (TC y)"
 
 definition le_TC (infix "\<sqsubseteq>" 50)
   where "x \<sqsubseteq> y \<equiv> x \<sqsubset> y \<or> x=y"
 
 lemma less_TC_imp_not_le: "x \<sqsubset> a \<Longrightarrow> \<not> a \<le> x"
 proof (induction a arbitrary: x rule: eps_induct)
   case (step a)
   then show ?case
     unfolding TC[of a] less_TC_def
     using Transset_TC Transset_def by force
 qed
 
 lemma non_TC_less_0 [iff]: "\<not> (x \<sqsubset> 0)"
   using less_TC_imp_not_le by blast
 
 lemma less_TC_iff: "x \<sqsubset> y \<longleftrightarrow> (\<exists>z \<in> elts y. x \<sqsubseteq> z)"
   by (auto simp: less_TC_def le_TC_def TC [of y])
 
 lemma nonzero_less_TC: "x \<noteq> 0 \<Longrightarrow> 0 \<sqsubset> x"
   by (metis eps_induct le_TC_def less_TC_iff trad_foundation)
 
 lemma less_irrefl_TC [simp]: "\<not> x \<sqsubset> x"
   using less_TC_imp_not_le by blast
 
 lemma less_asym_TC: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> x\<rbrakk> \<Longrightarrow> False"
   by (metis TC_least Transset_TC Transset_def antisym_conv less_TC_def less_TC_imp_not_le order_refl)
 
 lemma le_antisym_TC: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> x\<rbrakk> \<Longrightarrow> x = y"
   using less_asym_TC by blast
 
 lemma less_imp_le_TC [iff]: "x \<sqsubset> y \<Longrightarrow> x \<sqsubseteq> y"
   by (simp add: le_TC_def)
 
 lemma le_TC_refl [iff]: "x \<sqsubseteq> x"
   by (simp add: le_TC_def)
 
 lemma less_TC_trans [trans]: "\<lbrakk>x \<sqsubset> y; y \<sqsubset> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
   by (meson TC_least Transset_TC Transset_def less_TC_def less_eq_V_def subsetD)
 
 lemma less_le_TC_trans [trans]: "\<lbrakk>x \<sqsubset> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
   using le_TC_def less_TC_trans by blast
 
 lemma le_less_TC_trans [trans]: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubset> z\<rbrakk> \<Longrightarrow> x \<sqsubset> z"
   using le_TC_def less_TC_trans by blast
 
 lemma le_TC_trans [trans]: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
   using le_TC_def le_less_TC_trans by blast
 
 lemma TC_sup_distrib: "TC (x \<squnion> y) = TC x \<squnion> TC y"
   by (simp add: Sup_Un_distrib TC [of "x \<squnion> y"] TC [of x] TC [of y] image_Un sup.assoc sup_left_commute)
 
 lemma TC_Sup_distrib:
   assumes "small X" shows "TC (\<Squnion>X) = \<Squnion>(TC ` X)"
 proof -
   have "\<Squnion> X \<squnion> \<Squnion> (\<Union>x\<in>X. TC ` elts x) \<le> \<Squnion> (TC ` X)"
     using assms
     apply (auto simp: Sup_le_iff)
     using arg_subset_TC apply blast
     by (metis TC_least Transset_TC Transset_def arg_subset_TC vsubsetD)
   moreover have "\<Squnion> (TC ` X) \<le> \<Squnion> X \<squnion> \<Squnion> (\<Union>x\<in>X. TC ` elts x)"
   proof (clarsimp simp add: Sup_le_iff assms)
     show "\<exists>x\<in>X. y \<in> elts x"
       if "x \<in> X" "y \<in> elts (TC x)" "\<forall>x\<in>X. \<forall>u\<in>elts x. y \<notin> elts (TC u)" for x y
       using that by (auto simp: TC [of x])
   qed
   ultimately show ?thesis
     using Sup_Un_distrib TC [of "\<Squnion>X"] image_Union assms
     by (simp add: image_Union inf_sup_aci(5) sup.absorb_iff2)
 qed
 
 lemma TC': "TC x = x \<squnion> TC (\<Squnion> (elts x))"
   by (simp add: TC [of x] TC_Sup_distrib)
 
 lemma TC_eq_0_iff [simp]: "TC x = 0 \<longleftrightarrow> x=0"
   using arg_subset_TC by fastforce
 
 text\<open>A distinctive induction principle\<close>
 lemma TC_induct_down_lemma:
   assumes ab: "a \<sqsubset> b" and base: "b \<le> d"
       and step: "\<And>y z. \<lbrakk>y \<sqsubset> b; y \<in> elts d; z \<in> elts y\<rbrakk> \<Longrightarrow> z \<in> elts d"
     shows "a \<in> elts d"
 proof -
   have "Transset (TC b \<sqinter> d)"
     using Transset_TC
     unfolding Transset_def
     by (metis inf.bounded_iff less_TC_def less_eq_V_def local.step subsetI vsubsetD) 
   moreover have "b \<le> TC b \<sqinter> d"
     by (simp add: arg_subset_TC base)
   ultimately show ?thesis
     using TC_least [THEN vsubsetD] ab unfolding less_TC_def
     by (meson TC_least le_inf_iff vsubsetD)
 qed
 
 lemma TC_induct_down [consumes 1, case_names base step small]:
   assumes "a \<sqsubset> b"
     and "\<And>y. y \<in> elts b \<Longrightarrow> P y"
     and "\<And>y z. \<lbrakk>y \<sqsubset> b; P y; z \<in> elts y\<rbrakk> \<Longrightarrow> P z"
     and "small (Collect P)"
   shows "P a"
   using TC_induct_down_lemma [of a b "set (Collect P)"] assms
   by (metis elts_of_set mem_Collect_eq vsubsetI)
 
 subsection\<open>Rank of a set\<close>
 
 definition rank :: "V\<Rightarrow>V"
   where "rank a \<equiv> transrec (\<lambda>f x. set (\<Union>y\<in>elts x. elts (succ(f y)))) a"
 
 lemma rank: "rank a = set(\<Union>y \<in> elts a. elts (succ(rank y)))"
   by (subst rank_def [THEN def_transrec], simp)
 
 lemma rank_Sup: "rank a = \<Squnion>((\<lambda>y. succ(rank y)) ` elts a)"
   by (metis elts_Sup image_image rank replacement set_of_elts small_elts)
 
 lemma Ord_rank [simp]: "Ord(rank a)"
 proof (induction a rule: eps_induct)
   case (step x)
   then show ?case
     unfolding rank_Sup [of x]
     by (metis (mono_tags, lifting) Ord_Sup Ord_succ imageE)
 qed
 
 lemma rank_of_Ord: "Ord i \<Longrightarrow> rank i = i"
   apply (induction rule: Ord_induct)
   by (metis (no_types, lifting) Ord_equality SUP_cong rank_Sup)
 
 lemma Ord_iff_rank: "Ord x \<longleftrightarrow> rank x = x"
   using Ord_rank [of x] rank_of_Ord by fastforce
 
 lemma rank_lt: "a \<in> elts b \<Longrightarrow> rank a < rank b"
   apply (subst rank [of b])
   by (metis (no_types, lifting) Ord_mem_iff_lt Ord_rank small_UN UN_iff elts_of_set elts_succ insert_iff rank small_elts)
 
 lemma rank_0 [simp]: "rank 0 = 0"
   unfolding rank_def
   using transrec by fastforce
 
 lemma rank_succ [simp]: "rank(succ x) = succ(rank x)"
 proof (rule order_antisym)
   show "rank (succ x) \<le> succ (rank x)"
     apply (subst rank [of "succ x"])
     apply (metis (no_types, lifting) Sup_insert elts_of_set elts_succ equals0D image_insert rank small_sup_iff subset_insertI sup.orderE vsubsetI)
     done
   show "succ (rank x) \<le> rank (succ x)"
     by (metis (mono_tags, lifting) ZFC_in_HOL.Sup_upper elts_succ image_insert insertI1 rank_Sup replacement small_elts)
 qed
 
 lemma rank_mono: "a \<le> b \<Longrightarrow> rank a \<le> rank b"
   apply (rule vsubsetI)
   using rank [of a] rank [of b] small_UN by auto
 
 lemma VsetI: "rank b \<sqsubset> i \<Longrightarrow> b \<in> elts (Vset i)"
 proof (induction i arbitrary: b rule: eps_induct)
   case (step x)
   then consider "rank b \<in> elts x" | "(\<exists>y\<in>elts x. rank b \<in> elts (TC y))"
     using le_TC_def less_TC_def less_TC_iff by fastforce
   then have "\<exists>y\<in>elts x. b \<le> Vset y"
   proof cases
     case 1
     then have "b \<le> Vset (rank b)"
       unfolding less_eq_V_def subset_iff
       by (meson Ord_mem_iff_lt Ord_rank le_TC_refl less_TC_iff rank_lt step.IH)
     then show ?thesis
       using "1" by blast
   next
     case 2
     then show ?thesis
       using step.IH
       unfolding less_eq_V_def subset_iff less_TC_def
       by (meson Ord_mem_iff_lt Ord_rank Transset_TC Transset_def rank_lt vsubsetD)
   qed
   then show ?case
     by (simp add: Vset [of x])
 qed
 
 lemma Ord_VsetI: "\<lbrakk>Ord i; rank b < i\<rbrakk> \<Longrightarrow> b \<in> elts (Vset i)"
   by (meson Ord_mem_iff_lt Ord_rank VsetI arg_subset_TC less_TC_def vsubsetD)
 
 lemma arg_le_Vset_rank: "a \<le> Vset(rank a)"
   by (simp add: Ord_VsetI rank_lt vsubsetI)
 
 lemma two_in_Vset:
   obtains \<alpha> where  "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)"
   by (metis Ord_rank Ord_VsetI elts_of_set insert_iff rank_lt small_elts small_insert_iff)
 
 lemma rank_eq_0_iff [simp]: "rank x = 0 \<longleftrightarrow> x=0"
   using arg_le_Vset_rank by fastforce
 
 lemma small_ranks_imp_small:
   assumes "small (rank ` A)" shows "small A"
 proof -
   define i where "i \<equiv> set (\<Union>(elts ` (rank ` A)))"
   have "Ord i"
     unfolding i_def using Ord_Union Ord_rank assms imageE by blast
   have *: "Vset (rank x) \<le> (Vset i)" if "x \<in> A" for x
     unfolding i_def by (metis Ord_rank Sup_V_def ZFC_in_HOL.Sup_upper Vfrom_mono assms imageI le_less that)
   have "A \<subseteq> elts (VPow (Vset i))"
     by (meson "*" VPow_iff arg_le_Vset_rank order.trans subsetI)
   then show ?thesis
     using down by blast
 qed
 
 lemma rank_Union: "rank(\<Squnion> A) = \<Squnion> (rank ` A)"
 proof (rule order_antisym)
-  have "elts (SUP y\<in>elts (\<Squnion> A). succ (rank y)) \<subseteq> elts (\<Squnion> (rank ` A))"
+  have "elts (\<Squnion>y\<in>elts (\<Squnion> A). succ (rank y)) \<subseteq> elts (\<Squnion> (rank ` A))"
     apply auto(*SLOW*)
     using Ord_mem_iff_lt Ord_rank rank_lt apply blast
     by (meson less_le_not_le rank_lt vsubsetD)
   then show "rank (\<Squnion> A) \<le> \<Squnion> (rank ` A)"
     by (metis less_eq_V_def rank_Sup)
   show "\<Squnion> (rank ` A) \<le> rank (\<Squnion> A)"
   proof (cases "small A")
     case True
     then show ?thesis
       by (metis (mono_tags, lifting) ZFC_in_HOL.Sup_least ZFC_in_HOL.Sup_upper image_iff rank_mono)
   next
     case False
     then have "\<not> small (rank ` A)"
       using small_ranks_imp_small by blast
     then show ?thesis
       by blast
   qed
 qed
 
 lemma small_bounded_rank:  "small {x. rank x \<in> elts a}"
 proof -
   have "{x. rank x \<in> elts a} \<subseteq> {x. rank x \<sqsubset> a}"
     using less_TC_iff by auto
   also have "\<dots> \<subseteq> elts (Vset a)"
     using VsetI by blast
   finally show ?thesis
     using down by simp
 qed
 
 lemma small_bounded_rank_le:  "small {x. rank x \<le> a}"
   using small_bounded_rank [of "VPow a"] VPow_iff [of _ a]  by simp
 
 lemma TC_rank_lt: "a \<sqsubset> b \<Longrightarrow> rank a < rank b"
 proof (induction rule: TC_induct_down)
   case (base y)
   then show ?case
     by (simp add: rank_lt)
 next
   case (step y z)
   then show ?case
     using less_trans rank_lt by blast
 next
   case small
   show ?case
     apply (rule smaller_than_small [OF small_bounded_rank_le [of "rank b"]])
     by (simp add: Collect_mono less_V_def)
 qed
 
 lemma TC_rank_mem: "x \<sqsubset> y \<Longrightarrow> rank x \<in> elts (rank y)"
   by (simp add: Ord_mem_iff_lt TC_rank_lt)
 
 lemma wf_TC_less: "wf {(x,y). x \<sqsubset> y}"
   proof (rule wf_subset [OF wf_inv_image [OF foundation, of rank]])
     show "{(x, y). x \<sqsubset> y} \<subseteq> inv_image {(x, y). x \<in> elts y} rank"
       by (auto simp: TC_rank_mem inv_image_def)
 qed
 
 lemma less_TC_minimal:
   assumes "P a"
   obtains x where "P x" "x \<sqsubseteq> a" "\<And>y. y \<sqsubset> x \<Longrightarrow> \<not> P y"
   using wfE_min' [OF wf_TC_less, of "{x. P x \<and> x \<sqsubseteq> a}"]
   by simp (metis le_TC_def less_le_TC_trans assms)
 
 lemma Vfrom_rank_eq: "Vfrom A (rank(x)) = Vfrom A x"
 proof (rule order_antisym)
   show "Vfrom A (rank x) \<le> Vfrom A x"
   proof (induction x rule: eps_induct)
     case (step x)
-    have "(SUP j\<in>elts (rank x). VPow (Vfrom A j)) \<le> (SUP j\<in>elts x. VPow (Vfrom A j))"
+    have "(\<Squnion>j\<in>elts (rank x). VPow (Vfrom A j)) \<le> (\<Squnion>j\<in>elts x. VPow (Vfrom A j))"
       apply (rule Sup_least, clarify)
       apply (simp add: rank [of x])
       using step.IH
       by (metis Ord_rank OrdmemD Vfrom_mono2 dual_order.trans inf_sup_aci(5) less_V_def sup.orderE)
     then show ?case
       by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"] sup.coboundedI2)
 qed
   show "Vfrom A x \<le> Vfrom A (rank x)"
   proof (induction x rule: eps_induct)
     case (step x)
-    have "(SUP j\<in>elts x. VPow (Vfrom A j)) \<le> (SUP j\<in>elts (rank x). VPow (Vfrom A j))"
+    have "(\<Squnion>j\<in>elts x. VPow (Vfrom A j)) \<le> (\<Squnion>j\<in>elts (rank x). VPow (Vfrom A j))"
       using step.IH TC_rank_mem less_TC_iff by force
     then show ?case
       by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"] sup.coboundedI2)
   qed
 qed
 
 lemma Vfrom_succ: "Vfrom A (succ(i)) = A \<squnion> VPow(Vfrom A i)"
   by (metis Ord_rank Vfrom_rank_eq Vfrom_succ_Ord rank_succ)
 
 lemma Vset_succ_TC:
   assumes "x \<in> elts (Vset (ZFC_in_HOL.succ k))" "u \<sqsubset> x"
   shows "u \<in> elts (Vset k)"
   using assms
   apply (simp add: Vfrom_succ)
   using TC_least Transset_Vfrom less_TC_def by auto
 
 subsection\<open>Cardinal Numbers\<close>
 
 text\<open>We extend the membership relation to a wellordering\<close>
 definition VWO :: "(V \<times> V) set"
   where "VWO \<equiv> @r. {(x,y). x \<in> elts y} \<subseteq> r \<and> Well_order r \<and> Field r = UNIV"
 
 lemma VWO: "{(x,y). x \<in> elts y} \<subseteq> VWO \<and> Well_order VWO \<and> Field VWO = UNIV"
   unfolding VWO_def
   by (metis (mono_tags, lifting) VWO_def foundation someI_ex total_well_order_extension)
 
 lemma wf_VWO: "wf(VWO - Id)"
   using VWO well_order_on_def by blast
 
 lemma wf_Ord_less: "wf {(x, y). Ord y \<and> x < y}"
   by (metis (no_types, lifting) Ord_mem_iff_lt eps_induct wfPUNIVI wfP_def)
 
 lemma refl_VWO: "refl VWO"
   using VWO order_on_defs by fastforce
 
 lemma trans_VWO: "trans VWO"
   using VWO by (simp add: VWO wo_rel.TRANS wo_rel_def)
 
 lemma antisym_VWO: "antisym VWO"
   using VWO by (simp add: VWO wo_rel.ANTISYM wo_rel_def)
 
 lemma total_VWO: "total VWO"
     using VWO by (metis wo_rel.TOTAL wo_rel.intro)
 
 lemma total_VWOId: "total (VWO-Id)"
   by (simp add: total_VWO)
 
 lemma Linear_order_VWO: "Linear_order VWO"
   using VWO well_order_on_def by blast
 
 lemma wo_rel_VWO: "wo_rel VWO"
   using VWO wo_rel_def by blast
 
 subsubsection \<open>Transitive Closure and VWO\<close>
 
 lemma mem_imp_VWO: "x \<in> elts y \<Longrightarrow> (x,y) \<in> VWO"
   using VWO by blast
 
 lemma less_TC_imp_VWO: "x \<sqsubset> y \<Longrightarrow> (x,y) \<in> VWO"
   unfolding less_TC_def
 proof (induction y arbitrary: x rule: eps_induct)
   case (step y' u)
   then consider "u \<in> elts y'" | v where "v \<in> elts y'" "u \<in> elts (TC v)"
     by (auto simp: TC [of y'])
   then show ?case
   proof cases
     case 2
     then show ?thesis
       by (meson mem_imp_VWO step.IH transD trans_VWO)
   qed (use mem_imp_VWO in blast)
 qed
 
 lemma le_TC_imp_VWO: "x \<sqsubseteq> y \<Longrightarrow> (x,y) \<in> VWO"
   apply (auto simp: le_TC_def less_TC_imp_VWO)
   by (metis Diff_iff Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO)
 
 lemma le_TC_0_iff [simp]: "x \<sqsubseteq> 0 \<longleftrightarrow> x = 0"
   by (simp add: le_TC_def)
 
 lemma less_TC_succ: " x \<sqsubset> succ \<beta> \<longleftrightarrow> x \<sqsubset> \<beta> \<or> x = \<beta>"
   by (metis elts_succ insert_iff le_TC_def less_TC_iff)
 
 lemma le_TC_succ: "x \<sqsubseteq> succ \<beta> \<longleftrightarrow> x \<sqsubseteq> \<beta> \<or> x = succ \<beta>"
   by (simp add: le_TC_def less_TC_succ)
 
 lemma Transset_TC_eq [simp]: "Transset x \<Longrightarrow> TC x = x"
   by (simp add: TC_least arg_subset_TC eq_iff)
 
 lemma Ord_TC_less_iff: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> \<beta> \<sqsubset> \<alpha> \<longleftrightarrow> \<beta> < \<alpha>"
   by (metis Ord_def Ord_mem_iff_lt Transset_TC_eq less_TC_def)
 
 lemma Ord_mem_iff_less_TC: "Ord l \<Longrightarrow> k \<in> elts l \<longleftrightarrow> k \<sqsubset> l"
   by (simp add: Ord_def less_TC_def)
 
 lemma le_TC_Ord: "\<lbrakk>\<beta> \<sqsubseteq> \<alpha>; Ord \<alpha>\<rbrakk> \<Longrightarrow> Ord \<beta>"
   by (metis Ord_def Ord_in_Ord Transset_TC_eq le_TC_def less_TC_def)
 
 lemma Ord_less_TC_mem:
   assumes "Ord \<alpha>" "\<beta> \<sqsubset> \<alpha>" shows "\<beta> \<in> elts \<alpha>"
   using Ord_def assms less_TC_def by auto
 
 lemma VWO_TC_le: "\<lbrakk>Ord \<alpha>; Ord \<beta>; (\<beta>, \<alpha>) \<in> VWO\<rbrakk> \<Longrightarrow> \<beta> \<sqsubseteq> \<alpha>"
 proof (induct \<alpha> arbitrary: \<beta> rule: Ord_induct)
   case (step \<alpha>)
   then show ?case
     by (metis Diff_iff Linear_order_VWO Linear_order_in_diff_Id Ord_TC_less_iff Ord_linear2 UNIV_I VWO le_TC_def le_less less_TC_imp_VWO pair_in_Id_conv)
 qed
 
 lemma VWO_iff_Ord_le [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> (\<beta>, \<alpha>) \<in> VWO \<longleftrightarrow> \<beta> \<le> \<alpha>"
   by (metis VWO_TC_le Ord_TC_less_iff le_TC_def le_TC_imp_VWO le_less)
 
 lemma zero_TC_le [iff]: "0 \<sqsubseteq> y"
   using le_TC_def nonzero_less_TC by auto
 
 lemma succ_le_TC_iff: "Ord j \<Longrightarrow> succ i \<sqsubseteq> j \<longleftrightarrow> i \<sqsubset> j"
   by (metis Ord_in_Ord Ord_linear Ord_mem_iff_less_TC Ord_succ le_TC_def less_TC_succ less_asym_TC)
 
 lemma VWO_0_iff [simp]: "(x,0) \<in> VWO \<longleftrightarrow> x=0"
 proof
   show "x = 0" if "(x, 0) \<in> VWO"
     using zero_TC_le [of x] le_TC_imp_VWO that
     by (metis DiffI Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO pair_in_Id_conv)
 qed auto
 
 lemma VWO_antisym:
   assumes "(x,y) \<in> VWO" "(y,x) \<in> VWO" shows "x=y"
   by (metis Diff_iff IdD Linear_order_VWO Linear_order_in_diff_Id UNIV_I VWO assms)
 
 subsubsection \<open>Relation VWF\<close>
 
 definition VWF where "VWF \<equiv> VWO - Id"
 
 lemma wf_VWF [iff]: "wf VWF"
   by (simp add: VWF_def wf_VWO)
 
 lemma trans_VWF [iff]: "trans VWF"
   by (simp add: VWF_def antisym_VWO trans_VWO trans_diff_Id)
 
 lemma asym_VWF [iff]: "asym VWF"
   by (metis VWF_def asym.intros irrefl_diff_Id wf_VWF wf_not_sym)
 
 lemma total_VWF [iff]: "total VWF"
   using VWF_def total_VWOId by auto
 
 lemma total_on_VWF [iff]: "total_on A VWF"
   by (meson UNIV_I total_VWF total_on_def)
 
 lemma VWF_asym:
   assumes "(x,y) \<in> VWF" "(y,x) \<in> VWF" shows False
   using VWF_def assms wf_VWO wf_not_sym by fastforce
 
 lemma VWF_non_refl [iff]: "(x,x) \<notin> VWF"
   by simp
 
 lemma VWF_iff_Ord_less [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> (\<alpha>,\<beta>) \<in> VWF \<longleftrightarrow> \<alpha> < \<beta>"
   by (simp add: VWF_def less_V_def)
 
 lemma mem_imp_VWF: "x \<in> elts y \<Longrightarrow> (x,y) \<in> VWF"
   using VWF_def mem_imp_VWO by fastforce
 
 
 subsection\<open>Order types\<close>
 
 definition ordermap :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> V"
   where "ordermap A r \<equiv> wfrec r (\<lambda>f x. set (f ` {y \<in> A. (y,x) \<in> r}))"
 
 definition ordertype :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> V"
   where "ordertype A r \<equiv> set (ordermap A r ` A)"
 
 lemma ordermap_type:
     "small A \<Longrightarrow> ordermap A r \<in> A \<rightarrow> elts (ordertype A r)"
   by (simp add: ordertype_def)
 
 lemma ordermap_in_ordertype [intro]: "\<lbrakk>a \<in> A; small A\<rbrakk> \<Longrightarrow> ordermap A r a \<in> elts (ordertype A r)"
   by (simp add: ordertype_def)
 
 lemma ordermap: "wf r \<Longrightarrow> ordermap A r a = set (ordermap A r ` {y \<in> A. (y,a) \<in> r})"
   unfolding ordermap_def
   by (auto simp: wfrec_fixpoint adm_wf_def)
 
 lemma wf_Ord_ordermap [iff]: assumes "wf r" "trans r" shows "Ord (ordermap A r x)"
   using \<open>wf r\<close>
 proof (induction x rule: wf_induct_rule)
   case (less u)
   have "Transset (set (ordermap A r ` {y \<in> A. (y, u) \<in> r}))"
   proof (clarsimp simp add: Transset_def)
     show "x \<in> ordermap A r ` {y \<in> A. (y, u) \<in> r}"
       if "small (ordermap A r ` {y \<in> A. (y, u) \<in> r})"
         and x: "x \<in> elts (ordermap A r y)" and "y \<in> A" "(y, u) \<in> r" for x y
     proof -
       have "ordermap A r y = ZFC_in_HOL.set (ordermap A r ` {a \<in> A. (a, y) \<in> r})"
         using ordermap assms(1) by force
       then have "x \<in> ordermap A r ` {z \<in> A. (z, y) \<in> r}"
         by (metis (no_types, lifting) elts_of_set empty_iff x)
       then have "\<exists>v. v \<in> A \<and> (v, u) \<in> r \<and> x = ordermap A r v"
         using that transD [OF \<open>trans r\<close>] by blast
       then show ?thesis
         by blast
     qed
   qed
   moreover have "Ord x"
     if "x \<in> elts (set (ordermap A r ` {y \<in> A. (y, u) \<in> r}))" for x
     using that less by (auto simp: split: if_split_asm)
   ultimately show ?case
     by (metis (full_types) Ord_def ordermap assms(1))
 qed
 
 lemma wf_Ord_ordertype: assumes "wf r" "trans r" shows "Ord(ordertype A r)"
 proof -
   have "y \<le> set (ordermap A r ` A)"
     if "y = ordermap A r x" "x \<in> A" "small (ordermap A r ` A)" for x y
     using that by (auto simp: less_eq_V_def ordermap [OF \<open>wf r\<close>, of A x])
   moreover have "z \<le> y" if "y \<in> ordermap A r ` A" "z \<in> elts y" for y z
     by (metis wf_Ord_ordermap OrdmemD assms imageE order.strict_implies_order that)
   ultimately show ?thesis
     unfolding ordertype_def Ord_def Transset_def by simp
 qed
 
 lemma Ord_ordertype [simp]: "Ord(ordertype A VWF)"
   using wf_Ord_ordertype by blast
 
 lemma Ord_ordermap [simp]: "Ord (ordermap A VWF x)"
   by blast
 
 lemma ordertype_singleton [simp]:
   assumes "wf r" 
   shows "ordertype {x} r = 1"
 proof -
   have \<dagger>: "{y. y = x \<and> (y, x) \<in> r} = {}"
     using assms by auto
   show ?thesis
     by (auto simp add: ordertype_def assms \<dagger> ordermap [where a=x])
 qed
 
 
 subsubsection\<open>@{term ordermap} preserves the orderings in both directions\<close>
 
 lemma ordermap_mono:
   assumes wx: "(w, x) \<in> r" and "wf r" "w \<in> A" "small A"
     shows "ordermap A r w \<in> elts (ordermap A r x)"
 proof -
   have "small {a \<in> A. (a, x) \<in> r} \<and> w \<in> A \<and> (w, x) \<in> r"
     by (simp add: assms)
   then show ?thesis
     using assms ordermap [of r A]
     by (metis (no_types, lifting) elts_of_set image_eqI mem_Collect_eq replacement)
 qed
 
 lemma converse_ordermap_mono:
   assumes "ordermap A r y \<in> elts (ordermap A r x)" "wf r" "total_on A r" "x \<in> A" "y \<in> A" "small A"
   shows "(y, x) \<in> r"
 proof (cases "x = y")
   case True
   then show ?thesis
     using assms(1) mem_not_refl by blast
 next
   case False
   then consider "(x,y) \<in> r" | "(y,x) \<in> r"
     using \<open>total_on A r\<close> assms by (meson UNIV_I total_on_def)
   then show ?thesis
     by (meson ordermap_mono assms mem_not_sym)
 qed
 
 lemma converse_ordermap_mono_iff:
   assumes "wf r" "total_on A r" "x \<in> A" "y \<in> A" "small A"
   shows "ordermap A r y \<in> elts (ordermap A r x) \<longleftrightarrow> (y, x) \<in> r"
   by (metis assms converse_ordermap_mono ordermap_mono)
 
 lemma ordermap_surj: "elts (ordertype A r) \<subseteq> ordermap A r ` A"
   unfolding ordertype_def by simp
 
 lemma ordermap_bij:
   assumes "wf r" "total_on A r" "small A"
   shows "bij_betw (ordermap A r) A (elts (ordertype A r))"
   unfolding bij_betw_def
   proof (intro conjI)
     show "inj_on (ordermap A r) A"
     unfolding inj_on_def by (metis assms mem_not_refl ordermap_mono total_on_def)
   show "ordermap A r ` A = elts (ordertype A r)"
     by (metis ordertype_def \<open>small A\<close> elts_of_set replacement)
 qed
 
 lemma ordermap_eq_iff [simp]: 
   "\<lbrakk>x \<in> A; y \<in> A; wf r; total_on A r; small A\<rbrakk> \<Longrightarrow> ordermap A r x = ordermap A r y \<longleftrightarrow> x = y"
   by (metis bij_betw_iff_bijections ordermap_bij)
 
 lemma inv_into_ordermap: "\<alpha> \<in> elts (ordertype A r) \<Longrightarrow> inv_into A (ordermap A r) \<alpha> \<in> A"
   by (meson in_mono inv_into_into ordermap_surj)
 
 lemma ordertype_nat_imp_finite:
   assumes "ordertype A r = ord_of_nat m" "small A" "wf r" "total_on A r"
   shows "finite A"
 proof -
   have "A \<approx> elts m"
     using eqpoll_def assms ordermap_bij by fastforce 
   then show ?thesis
     using eqpoll_finite_iff finite_Ord_omega by blast
 qed
 
 lemma wf_ordertype_eqpoll:
   assumes "wf r" "total_on A r" "small A"
   shows "elts (ordertype A r) \<approx> A"
   using assms eqpoll_def eqpoll_sym ordermap_bij by blast
 
 lemma ordertype_eqpoll:
   assumes "small A"
   shows "elts (ordertype A VWF) \<approx> A"
   using assms wf_ordertype_eqpoll total_VWF wf_VWF
   by (simp add: wf_ordertype_eqpoll total_on_def)
 
 subsection \<open>More advanced @{term ordertype} and @{term ordermap} results\<close>
 
 lemma ordermap_VWF_0 [simp]: "ordermap A VWF 0 = 0"
   by (simp add: ordermap wf_VWO VWF_def)
 
 lemma ordertype_empty [simp]: "ordertype {} r = 0"
   by (simp add: ordertype_def)
 
 lemma ordertype_eq_0_iff [simp]: "\<lbrakk>small X; wf r\<rbrakk> \<Longrightarrow> ordertype X r = 0 \<longleftrightarrow> X = {}"
   by (metis ordertype_def elts_of_set replacement image_is_empty zero_V_def)
 
 lemma ordermap_mono_less:
   assumes "(w, x) \<in> r"
       and "wf r" "trans r"
       and "w \<in> A" "x \<in> A"
       and "small A"
     shows "ordermap A r w < ordermap A r x"
   by (simp add: OrdmemD assms ordermap_mono)
 
 lemma ordermap_mono_le:
   assumes "(w, x) \<in> r \<or> w=x"
       and "wf r" "trans r"
       and "w \<in> A" "x \<in> A"
       and "small A"
     shows "ordermap A r w \<le> ordermap A r x"
   by (metis assms dual_order.strict_implies_order eq_refl ordermap_mono_less)
 
 lemma converse_ordermap_le_mono:
   assumes "ordermap A r y \<le> ordermap A r x" "wf r" "total r"  "x \<in> A" "small A"
   shows "(y, x) \<in> r \<or> y=x"
   by (meson UNIV_I assms mem_not_refl ordermap_mono total_on_def vsubsetD)
 
 lemma ordertype_mono:
   assumes "X \<subseteq> Y" and r: "wf r" "trans r" and "small Y"
   shows "ordertype X r \<le> ordertype Y r"
 proof -
   have "small X"
     using assms smaller_than_small by fastforce 
   have *: "ordermap X r x \<le> ordermap Y r x" for x
     using \<open>wf r\<close>
   proof (induction x rule: wf_induct_rule)
     case (less x)
     have "ordermap X r z < ordermap Y r x" if "z \<in> X" and zx: "(z,x) \<in> r" for z
       using less [OF zx] assms
       by (meson Ord_linear2 OrdmemD wf_Ord_ordermap ordermap_mono in_mono leD that(1) vsubsetD zx)
     then show ?case
       by (auto simp add: ordermap [of _ X x] \<open>small X\<close> Ord_mem_iff_lt set_image_le_iff less_eq_V_def r)
   qed
   show ?thesis
   proof -
     have "ordermap Y r ` Y = elts (ordertype Y r)"
       by (metis ordertype_def \<open>small Y\<close> elts_of_set replacement)
     then have "ordertype Y r \<notin> ordermap X r ` X"
       using "*" \<open>X \<subseteq> Y\<close> by fastforce
     then show ?thesis
       by (metis Ord_linear2 Ord_mem_iff_lt ordertype_def wf_Ord_ordertype \<open>small X\<close> elts_of_set replacement r)
   qed
 qed
 
 corollary ordertype_VWF_mono:
   assumes "X \<subseteq> Y" "small Y"
   shows "ordertype X VWF \<le> ordertype Y VWF"
   using assms by (simp add: ordertype_mono)
 
 lemma ordertype_UNION_ge:
   assumes "A \<in> \<A>" "wf r" "trans r" "\<A> \<subseteq> Collect small" "small \<A>"
   shows "ordertype A r \<le> ordertype (\<Union>\<A>) r" 
   by (rule ordertype_mono) (use assms in auto)
 
 lemma inv_ordermap_mono_less:
   assumes "(inv_into M (ordermap M r) \<alpha>, inv_into M (ordermap M r) \<beta>) \<in> r" 
     and "small M" and \<alpha>: "\<alpha> \<in> elts (ordertype M r)" and \<beta>: "\<beta> \<in> elts (ordertype M r)"
     and "wf r" "trans r"
   shows "\<alpha> < \<beta>"
 proof -
   have "\<alpha> = ordermap M r (inv_into M (ordermap M r) \<alpha>)"
     by (metis \<alpha> f_inv_into_f ordermap_surj subset_eq)
   also have "\<dots> < ordermap M r (inv_into M (ordermap M r) \<beta>)"
     by (meson \<alpha> \<beta> assms in_mono inv_into_into ordermap_mono_less ordermap_surj)
   also have "\<dots> = \<beta>"
     by (meson \<beta> f_inv_into_f in_mono ordermap_surj)
   finally show ?thesis .
 qed
 
 lemma inv_ordermap_mono_eq:
   assumes "inv_into M (ordermap M r) \<alpha> = inv_into M (ordermap M r) \<beta>" 
     and "\<alpha> \<in> elts (ordertype M r)" "\<beta> \<in> elts (ordertype M r)"
   shows "\<alpha> = \<beta>"
   by (metis assms f_inv_into_f ordermap_surj subsetD)
 
 lemma inv_ordermap_VWF_mono_le:
   assumes "inv_into M (ordermap M VWF) \<alpha> \<le> inv_into M (ordermap M VWF) \<beta>" 
     and "M \<subseteq> ON" "small M" and \<alpha>: "\<alpha> \<in> elts (ordertype M VWF)" and \<beta>: "\<beta> \<in> elts (ordertype M VWF)"
   shows "\<alpha> \<le> \<beta>"
 proof -
   have "\<alpha> = ordermap M VWF (inv_into M (ordermap M VWF) \<alpha>)"
     by (metis \<alpha> f_inv_into_f ordermap_surj subset_eq)
   also have "\<dots> \<le> ordermap M VWF (inv_into M (ordermap M VWF) \<beta>)"
     by (metis ON_imp_Ord VWF_iff_Ord_less assms dual_order.strict_implies_order elts_of_set eq_refl inv_into_into order.not_eq_order_implies_strict ordermap_mono_less ordertype_def replacement trans_VWF wf_VWF)
   also have "\<dots> = \<beta>"
     by (meson \<beta> f_inv_into_f in_mono ordermap_surj)
   finally show ?thesis .
 qed
 
 lemma inv_ordermap_VWF_mono_iff:
   assumes "M \<subseteq> ON" "small M" and "\<alpha> \<in> elts (ordertype M VWF)" and "\<beta> \<in> elts (ordertype M VWF)"
   shows "inv_into M (ordermap M VWF) \<alpha> \<le> inv_into M (ordermap M VWF) \<beta> \<longleftrightarrow> \<alpha> \<le> \<beta>"
   by (metis ON_imp_Ord Ord_linear_le assms dual_order.eq_iff inv_into_ordermap inv_ordermap_VWF_mono_le)
 
 lemma inv_ordermap_VWF_strict_mono_iff:
   assumes "M \<subseteq> ON" "small M" and "\<alpha> \<in> elts (ordertype M VWF)" and "\<beta> \<in> elts (ordertype M VWF)"
   shows "inv_into M (ordermap M VWF) \<alpha> < inv_into M (ordermap M VWF) \<beta> \<longleftrightarrow> \<alpha> < \<beta>"
   by (simp add: assms inv_ordermap_VWF_mono_iff less_le_not_le)
 
 lemma strict_mono_on_ordertype:
   assumes "M \<subseteq> ON" "small M"
   obtains f where "f \<in> elts (ordertype M VWF) \<rightarrow> M" "strict_mono_on f (elts (ordertype M VWF))"
 proof 
   show "inv_into M (ordermap M VWF) \<in> elts (ordertype M VWF) \<rightarrow> M"
     by (meson Pi_I' in_mono inv_into_into ordermap_surj)
   show "strict_mono_on (inv_into M (ordermap M VWF)) (elts (ordertype M VWF))"
   proof (clarsimp simp: strict_mono_on_def)
     fix x y
     assume "x \<in> elts (ordertype M VWF)" "y \<in> elts (ordertype M VWF)" "x < y"
     then show "inv_into M (ordermap M VWF) x < inv_into M (ordermap M VWF) y"
       using assms by (meson ON_imp_Ord Ord_linear2 inv_into_into inv_ordermap_VWF_mono_le leD ordermap_surj subsetD)
   qed
 qed
 
 lemma ordermap_inc_eq:
   assumes "x \<in> A" "small A"
     and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
     and r: "wf r" "total_on A r" and "wf s" 
   shows "ordermap (\<pi> ` A) s (\<pi> x) = ordermap A r x"
   using \<open>wf r\<close> \<open>x \<in> A\<close>
 proof (induction x rule: wf_induct_rule)
   case (less x)
   then have 1: "{y \<in> A. (y, x) \<in> r} = A \<inter> {y. (y, x) \<in> r}"
     using r by auto
   have 2: "{y \<in> \<pi> ` A. (y, \<pi> x) \<in> s} = \<pi> ` A \<inter> {y. (y, \<pi> x) \<in> s}"
     by auto
   have inv\<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (\<pi> x, \<pi> y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r"
     by (metis \<pi> \<open>wf s\<close> \<open>total_on A r\<close> total_on_def wf_not_sym)
   have eq: "f ` (\<pi> ` A \<inter> {y. (y, \<pi> x) \<in> s}) = (f \<circ> \<pi>) ` (A \<inter> {y. (y, x) \<in> r})" for f :: "'b \<Rightarrow> V"
     using less by (auto simp: image_subset_iff inv\<pi> \<pi>)
   show ?case
     using less
     by (simp add: ordermap [OF \<open>wf r\<close>, of _ x] ordermap [OF \<open>wf s\<close>, of _ "\<pi> x"] 1 2 eq)
 qed
 
 lemma ordertype_inc_eq:
   assumes "small A"
     and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
     and r: "wf r" "total_on A r" and "wf s" 
   shows "ordertype (\<pi> ` A) s = ordertype A r"
 proof -
   have "ordermap (\<pi> ` A) s (\<pi> x) = ordermap A r x" if "x \<in> A" for x
     using assms that by (auto simp: ordermap_inc_eq)
   then show ?thesis
     unfolding ordertype_def
     by (metis (no_types, lifting) image_cong image_image)
 qed
 
 lemma ordertype_inc_le:
   assumes "small A" "small B"
     and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> s"
     and r: "wf r" "total_on A r" and "wf s" "trans s"
     and "\<pi> ` A \<subseteq> B"
   shows "ordertype A r \<le> ordertype B s"
   by (metis assms ordertype_inc_eq ordertype_mono)
 
 corollary ordertype_VWF_inc_eq:
   assumes "A \<subseteq> ON" "\<pi> ` A \<subseteq> ON" "small A" and "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; x<y\<rbrakk> \<Longrightarrow> \<pi> x < \<pi> y"
   shows "ordertype (\<pi> ` A) VWF = ordertype A VWF"
 proof (rule ordertype_inc_eq)
   show "(\<pi> x, \<pi> y) \<in> VWF"
     if "x \<in> A" "y \<in> A" "(x, y) \<in> VWF" for x y
     using that ON_imp_Ord assms by auto
   show "total_on A VWF"
     by (meson UNIV_I total_VWF total_on_def)
 qed (use assms in auto)
 
 lemma ordertype_image_ordermap:
   assumes "small A" "X \<subseteq> A" "wf r" "trans r" "total_on X r"
   shows "ordertype (ordermap A r ` X) VWF = ordertype X r"
 proof (rule ordertype_inc_eq)
   show "small X"
     by (meson assms smaller_than_small)
   show "(ordermap A r x, ordermap A r y) \<in> VWF"
     if "x \<in> X" "y \<in> X" "(x, y) \<in> r" for x y
     by (meson that wf_Ord_ordermap VWF_iff_Ord_less assms ordermap_mono_less subsetD)
 qed (use assms in auto)
     
 lemma ordertype_map_image:
   assumes "B \<subseteq> A" "small A"
   shows "ordertype (ordermap A VWF ` A - ordermap A VWF ` B) VWF = ordertype (A - B) VWF"
 proof -
   have "ordermap A VWF ` A - ordermap A VWF ` B = ordermap A VWF ` (A - B)"
     using assms by auto
   then have "ordertype (ordermap A VWF ` A - ordermap A VWF ` B) VWF = ordertype (ordermap A VWF ` (A - B)) VWF"
     by simp
   also have "\<dots> = ordertype (A - B) VWF"
     using \<open>small A\<close> ordertype_image_ordermap by fastforce
   finally show ?thesis .
 qed
 
 proposition ordertype_le_ordertype:
   assumes r: "wf r" "total_on A r" and "small A"
   assumes s: "wf s" "total_on B s" "trans s" and "small B"
   shows "ordertype A r \<le> ordertype B s \<longleftrightarrow>
          (\<exists>f \<in> A \<rightarrow> B. inj_on f A \<and> (\<forall>x \<in> A. \<forall>y \<in> A. ((x,y) \<in> r \<longrightarrow> (f x, f y) \<in> s)))"
     (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   define f where "f \<equiv> inv_into B (ordermap B s) \<circ> ordermap A r"
   show ?rhs
   proof (intro bexI conjI ballI impI)
     have AB: "elts (ordertype A r) \<subseteq> ordermap B s ` B"
       by (metis L assms(7) ordertype_def replacement set_of_elts small_elts subset_iff_less_eq_V)
     have bijA: "bij_betw (ordermap A r) A (elts (ordertype A r))"
       using ordermap_bij \<open>small A\<close> r by blast
     have "inv_into B (ordermap B s) (ordermap A r i) \<in> B" if "i \<in> A" for i
       by (meson L \<open>small A\<close> inv_into_into ordermap_in_ordertype ordermap_surj subsetD that vsubsetD)
     then show "f \<in> A \<rightarrow> B"
       by (auto simp: Pi_iff f_def)
     show "inj_on f A"
     proof (clarsimp simp add: f_def inj_on_def)
       fix x y
       assume "x \<in> A" "y \<in> A"
         and "inv_into B (ordermap B s) (ordermap A r x) = inv_into B (ordermap B s) (ordermap A r y)"
       then have "ordermap A r x = ordermap A r y"
         by (meson AB \<open>small A\<close> inv_into_injective ordermap_in_ordertype subsetD)
       then show "x = y"
         by (metis \<open>x \<in> A\<close> \<open>y \<in> A\<close> bijA bij_betw_inv_into_left)
     qed
   next
     fix x y
     assume "x \<in> A" "y \<in> A" and "(x, y) \<in> r"
     have \<ddagger>: "ordermap A r y \<in> ordermap B s ` B"
       by (meson L \<open>y \<in> A\<close> \<open>small A\<close> in_mono ordermap_in_ordertype ordermap_surj vsubsetD)
     moreover have \<dagger>: "\<And>x. inv_into B (ordermap B s) (ordermap A r x) = f x"
       by (simp add: f_def)
     then have *: "ordermap B s (f y) = ordermap A r y"
       using \<ddagger> by (metis f_inv_into_f)
     moreover have "ordermap A r x \<in> ordermap B s ` B"
       by (meson L \<open>x \<in> A\<close> \<open>small A\<close> in_mono ordermap_in_ordertype ordermap_surj vsubsetD)
     moreover have "ordermap A r x < ordermap A r y"
       using * r s by (metis (no_types) wf_Ord_ordermap OrdmemD \<open>(x, y) \<in> r\<close> \<open>x \<in> A\<close> \<open>small A\<close> ordermap_mono)
     ultimately show "(f x, f y) \<in> s"
       using \<dagger> s by (metis assms(7) f_inv_into_f inv_into_into less_asym ordermap_mono_less total_on_def)
   qed
 next
   assume R: ?rhs
   then obtain f where f: "f\<in>A \<rightarrow> B" "inj_on f A" "\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> r \<longrightarrow> (f x, f y) \<in> s"
     by blast
   show ?lhs
     by (rule ordertype_inc_le [where \<pi>=f]) (use f assms in auto)
 qed
 
 lemma iso_imp_ordertype_eq_ordertype:
   assumes iso: "iso r r' f"
     and "wf r"
     and "Total r"
     and sm: "small (Field r)"
   shows "ordertype (Field r) r = ordertype (Field r') r'"
   by (metis (no_types, lifting) iso_forward iso_wf assms iso_Field ordertype_inc_eq sm)
 
 lemma ordertype_infinite_ge_\<omega>:
   assumes "infinite A" "small A"
   shows "ordertype A VWF \<ge> \<omega>"
 proof -
   have "inj_on (ordermap A VWF) A"
     by (meson ordermap_bij \<open>small A\<close> bij_betw_def total_on_VWF wf_VWF)
   then have "infinite (ordermap A VWF ` A)"
     using \<open>infinite A\<close> finite_image_iff by blast
   then show ?thesis
     using Ord_ordertype \<open>small A\<close> infinite_Ord_omega by (auto simp: ordertype_def)
 qed
 
 lemma ordertype_eqI:
   assumes "wf r" "total_on A r" "small A" "wf s" 
           "bij_betw f A B" "(\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r)"
   shows "ordertype A r = ordertype B s"
   by (metis assms bij_betw_imp_surj_on ordertype_inc_eq)
 
 lemma ordermap_eq_self:
   assumes "Ord \<alpha>" and x: "x \<in> elts \<alpha>" 
   shows "ordermap (elts \<alpha>) VWF x = x" 
   using Ord_in_Ord [OF assms] x 
 proof (induction x rule: Ord_induct)
   case (step x)
   have 1: "{y \<in> elts \<alpha>. (y, x) \<in> VWF} = elts x" (is "?A = _")
   proof
     show "?A \<subseteq> elts x"
       using \<open>Ord \<alpha>\<close> by clarify (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less step.hyps)
     show "elts x \<subseteq> ?A"
       using \<open>Ord \<alpha>\<close> by clarify (meson Ord_in_Ord Ord_trans OrdmemD VWF_iff_Ord_less step.prems)
   qed
   show ?case
     using step
     by (simp add: ordermap [OF wf_VWF, of _ x] 1 Ord_trans [of _ _ \<alpha>] step.prems \<open>Ord \<alpha>\<close> cong: image_cong)
 qed
 
 lemma ordertype_eq_Ord [simp]:
   assumes "Ord \<alpha>" 
   shows "ordertype (elts \<alpha>) VWF = \<alpha>"
   using assms ordermap_eq_self [OF assms] by (simp add: ordertype_def)
 
 
 proposition ordertype_eq_iff:
   assumes \<alpha>: "Ord \<alpha>" and r: "wf r" and "small A" "total_on A r" "trans r"
   shows "ordertype A r = \<alpha> \<longleftrightarrow>
          (\<exists>f. bij_betw f A (elts \<alpha>) \<and> (\<forall>x \<in> A. \<forall>y \<in> A. f x < f y \<longleftrightarrow> (x,y) \<in> r))"
     (is "?lhs = ?rhs")
 proof safe
   assume eq: "\<alpha> = ordertype A r"
   show "\<exists>f. bij_betw f A (elts (ordertype A r)) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. f x < f y \<longleftrightarrow> ((x, y) \<in> r))"
   proof (intro exI conjI ballI)
     show "bij_betw (ordermap A r) A (elts (ordertype A r))"
       by (simp add: assms ordermap_bij)
     then show "ordermap A r x < ordermap A r y \<longleftrightarrow> (x, y) \<in> r"
       if "x \<in> A" "y \<in> A" for x y
       using that assms
       by (metis order.asym ordermap_mono_less total_on_def)
   qed
 next
   fix f 
   assume f: "bij_betw f A (elts \<alpha>)" "\<forall>x\<in>A. \<forall>y\<in>A. f x < f y \<longleftrightarrow> (x, y) \<in> r"
   have "ordertype A r = ordertype (elts \<alpha>) VWF"
   proof (rule ordertype_eqI)
     show "\<forall>x\<in>A. \<forall>y\<in>A. ((f x, f y) \<in> VWF) = ((x, y) \<in> r)"
       by (meson Ord_in_Ord VWF_iff_Ord_less \<alpha> bij_betwE f)
   qed (use assms f in auto)
   then show ?lhs
     by (simp add: \<alpha>)
 qed
 
 corollary ordertype_VWF_eq_iff:
   assumes "Ord \<alpha>" "small A"
   shows "ordertype A VWF = \<alpha> \<longleftrightarrow>
          (\<exists>f. bij_betw f A (elts \<alpha>) \<and> (\<forall>x \<in> A. \<forall>y \<in> A. f x < f y \<longleftrightarrow> (x,y) \<in> VWF))"
   by (metis UNIV_I assms ordertype_eq_iff total_VWF total_on_def trans_VWF wf_VWF)
 
 
 lemma ordertype_le_Ord:
   assumes "Ord \<alpha>" "X \<subseteq> elts \<alpha>"
   shows "ordertype X VWF \<le> \<alpha>"
   by (metis assms ordertype_VWF_mono ordertype_eq_Ord small_elts)
 
 lemma ordertype_inc_le_Ord:
   assumes "small A" "Ord \<alpha>"
     and \<pi>: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> \<pi> x < \<pi> y"
     and "wf r" "total_on A r" 
     and sub: "\<pi> ` A \<subseteq> elts \<alpha>"
   shows "ordertype A r \<le> \<alpha>"
 proof -
   have "\<And>x y. \<lbrakk>x\<in>A; y\<in>A; (x,y) \<in> r\<rbrakk> \<Longrightarrow> (\<pi> x, \<pi> y) \<in> VWF"
     by (meson Ord_in_Ord VWF_iff_Ord_less \<pi> \<open>Ord \<alpha>\<close> sub image_subset_iff)
   with assms show ?thesis
     by (metis ordertype_inc_eq ordertype_le_Ord wf_VWF)
 qed
 
 lemma le_ordertype_obtains_subset:
   assumes \<alpha>: "\<beta> \<le> \<alpha>" "ordertype H VWF = \<alpha>" and "small H" "Ord \<beta>"
   obtains G where "G \<subseteq> H" "ordertype G VWF = \<beta>" 
 proof (intro exI conjI that)
   let ?f = "ordermap H VWF"
   show \<ddagger>: "inv_into H ?f ` elts \<beta> \<subseteq> H"
     unfolding image_subset_iff
     by (metis \<alpha> inv_into_into ordermap_surj subsetD vsubsetD)
   have "\<exists>f. bij_betw f (inv_into H ?f ` elts \<beta>) (elts \<beta>) \<and> (\<forall>x\<in>inv_into H ?f ` elts \<beta>. \<forall>y\<in>inv_into H ?f ` elts \<beta>. (f x < f y) = ((x, y) \<in> VWF))"
   proof (intro exI conjI ballI iffI)
     show "bij_betw ?f (inv_into H ?f ` elts \<beta>) (elts \<beta>)"
       using ordermap_bij [OF wf_VWF total_on_VWF \<open>small H\<close>] \<alpha> 
       by (metis bij_betw_inv_into_RIGHT bij_betw_subset less_eq_V_def \<ddagger>)
   next
     fix x y
     assume x: "x \<in> inv_into H ?f ` elts \<beta>"
         and y: "y \<in> inv_into H ?f ` elts \<beta>"
     show "?f x < ?f y" if "(x,y) \<in> VWF"
       using that \<ddagger> \<open>small H\<close> in_mono ordermap_mono_less x y by fastforce
     show "(x,y) \<in> VWF" if "?f x < ?f y"
       using that \<ddagger> \<open>small H\<close> in_mono ordermap_mono_less [OF _ wf_VWF trans_VWF] x y
       by (metis UNIV_I less_imp_not_less total_VWF total_on_def)
   qed
   then show "ordertype (inv_into H ?f ` elts \<beta>) VWF = \<beta>"
     by (subst ordertype_eq_iff) (use assms in auto)
 qed
 
 lemma ordertype_infinite_\<omega>:
   assumes "A \<subseteq> elts \<omega>" "infinite A"
   shows "ordertype A VWF = \<omega>"
 proof (rule antisym)
   show "ordertype A VWF \<le> \<omega>"
     by (simp add: assms ordertype_le_Ord)
   show "\<omega> \<le> ordertype A VWF"
     using assms down ordertype_infinite_ge_\<omega> by auto
 qed
 
 text \<open>For infinite sets of natural numbers\<close>
 lemma ordertype_nat_\<omega>:
   assumes "infinite N" shows "ordertype N less_than = \<omega>"
 proof -
   have "small N"
     by (meson inj_on_def ord_of_nat_inject small_def small_iff_range small_image_nat_V)
   have "ordertype (ord_of_nat ` N) VWF = \<omega>"
     by (force simp: assms finite_image_iff inj_on_def intro: ordertype_infinite_\<omega>)
   moreover have "ordertype (ord_of_nat ` N) VWF = ordertype N less_than"
     by (auto intro: ordertype_inc_eq \<open>small N\<close>)
   ultimately show ?thesis
     by simp
 qed
 
 proposition ordertype_eq_ordertype:
   assumes r: "wf r" "total_on A r" "trans r" and "small A"
   assumes s: "wf s" "total_on B s" "trans s" and "small B"
   shows "ordertype A r = ordertype B s \<longleftrightarrow>
          (\<exists>f. bij_betw f A B \<and> (\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r))"
     (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   define \<gamma> where "\<gamma> = ordertype A r"
   have A: "bij_betw (ordermap A r) A (ordermap A r ` A)"
     by (meson ordermap_bij assms(4) bij_betw_def r)
   have B: "bij_betw (ordermap B s) B (ordermap B s ` B)"
     by (meson ordermap_bij assms(8) bij_betw_def s)
   define f where "f \<equiv> inv_into B (ordermap B s) o ordermap A r"
   show ?rhs
   proof (intro exI conjI)
     have bijA: "bij_betw (ordermap A r) A (elts \<gamma>)"
       unfolding \<gamma>_def using ordermap_bij \<open>small A\<close> r by blast
     moreover have bijB: "bij_betw (ordermap B s) B (elts \<gamma>)"
       by (simp add: L \<gamma>_def ordermap_bij \<open>small B\<close> s)
     ultimately show bij: "bij_betw f A B"
       unfolding f_def using bij_betw_comp_iff bij_betw_inv_into by blast
     have invB: "\<And>\<alpha>. \<alpha> \<in> elts \<gamma> \<Longrightarrow> ordermap B s (inv_into B (ordermap B s) \<alpha>) = \<alpha>"
       by (meson bijB bij_betw_inv_into_right)
     have ordermap_A_\<gamma>: "\<And>a. a \<in> A \<Longrightarrow> ordermap A r a \<in> elts \<gamma>"
       using bijA bij_betwE by auto
     have f_in_B: "\<And>a. a \<in> A \<Longrightarrow> f a \<in> B"
       using bij bij_betwE by fastforce
     show "\<forall>x\<in>A. \<forall>y\<in>A. (f x, f y) \<in> s \<longleftrightarrow> (x, y) \<in> r"
     proof (intro iffI ballI)
       fix x y
       assume "x \<in> A" "y \<in> A" and ins: "(f x, f y) \<in> s"
       then have "ordermap A r x < ordermap A r y"
         unfolding o_def 
         by (metis (mono_tags, lifting) f_def \<open>small B\<close> comp_apply f_in_B invB ordermap_A_\<gamma> ordermap_mono_less s(1) s(3))
       then show "(x, y) \<in> r"
         by (metis \<open>x \<in> A\<close> \<open>y \<in> A\<close> \<open>small A\<close> order.asym ordermap_mono_less r total_on_def)
     next
       fix x y
       assume "x \<in> A" "y \<in> A" and "(x, y) \<in> r"
       then have "ordermap A r x < ordermap A r y"
         by (simp add: \<open>small A\<close> ordermap_mono_less r)
       then have "(f y, f x) \<notin> s"
         by (metis (mono_tags, lifting) \<open>x \<in> A\<close> \<open>y \<in> A\<close> \<open>small B\<close> comp_apply f_def f_in_B invB order.asym ordermap_A_\<gamma> ordermap_mono_less s(1) s(3))
       moreover have "f y \<noteq> f x"
         by (metis \<open>(x, y) \<in> r\<close> \<open>x \<in> A\<close> \<open>y \<in> A\<close> bij bij_betw_inv_into_left r(1) wf_not_sym)
       ultimately show "(f x, f y) \<in> s"
         by (meson \<open>x \<in> A\<close> \<open>y \<in> A\<close> f_in_B s(2) total_on_def)
     qed
   qed
 next
   assume ?rhs
   then show ?lhs
     using assms ordertype_eqI  by blast
 qed
 
 corollary ordertype_eq_ordertype_iso:
   assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field r = A"
   assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field s = B"
   shows "ordertype A r = ordertype B s \<longleftrightarrow> (\<exists>f. iso r s f)"
     (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   then obtain f where "bij_betw f A B" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r"
     using assms ordertype_eq_ordertype by blast
   then show ?rhs
     using FA FB iso_iff2 by blast
 next
   assume ?rhs
   then show ?lhs
     using FA FB \<open>small A\<close> iso_imp_ordertype_eq_ordertype r by blast
 qed
 
 lemma Limit_ordertype_imp_Field_Restr:
   assumes Lim: "Limit (ordertype A r)" and r: "wf r" "total_on A r" and "small A"
   shows "Field (Restr r A) = A"
 proof -
   have "\<exists>y\<in>A. (x,y) \<in> r" if "x \<in> A" for x
   proof -
     let ?oy = "succ (ordermap A r x)"
     have \<section>: "?oy \<in> elts (ordertype A r)"
       by (simp add: Lim \<open>small A\<close> ordermap_in_ordertype succ_in_Limit_iff that)
     then have A: "inv_into A (ordermap A r) ?oy \<in> A"
       by (simp add: inv_into_ordermap)
     moreover have "(x, inv_into A (ordermap A r) ?oy) \<in> r"
     proof -
       have "ordermap A r x \<in> elts (ordermap A r (inv_into A (ordermap A r) ?oy))"
         by (metis "\<section>" elts_succ f_inv_into_f insert_iff ordermap_surj subsetD)
       then show ?thesis
         by (metis \<open>small A\<close> A converse_ordermap_mono r that)
     qed
     ultimately show ?thesis ..
   qed
   then have "A \<subseteq> Field (Restr r A)"
     by (auto simp: Field_def)
   then show ?thesis
     by (simp add: Field_Restr_subset subset_antisym)
 qed
 
 lemma ordertype_Field_Restr:
   assumes "wf r" "total_on A r" "trans r" "small A" "Field (Restr r A) = A"
   shows "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r"
   using assms by (force simp: ordertype_eq_ordertype wf_Restr total_on_def trans_Restr)
 
 proposition ordertype_eq_ordertype_iso_Restr:
   assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field (Restr r A) = A"
   assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field (Restr s B) = B"
   shows "ordertype A r = ordertype B s \<longleftrightarrow> (\<exists>f. iso (Restr r A) (Restr s B) f)"
     (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   then obtain f where "bij_betw f A B" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r"
     using assms ordertype_eq_ordertype by blast
   then show ?rhs
     using FA FB bij_betwE unfolding iso_iff2 by fastforce
 next
   assume ?rhs
   moreover
   have "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r"
     using FA \<open>small A\<close> ordertype_Field_Restr r by blast
   moreover
   have "ordertype (Field (Restr s B)) (Restr s B) = ordertype B s"
     using FB \<open>small B\<close> ordertype_Field_Restr s by blast
   ultimately show ?lhs
     using iso_imp_ordertype_eq_ordertype FA FB \<open>small A\<close> r
     by (fastforce intro: total_on_imp_Total_Restr trans_Restr wf_Int1)
 qed
 
 lemma ordermap_insert:
   assumes "Ord \<alpha>" and y: "Ord y" "y \<le> \<alpha>" and U: "U \<subseteq> elts \<alpha>"
   shows "ordermap (insert \<alpha> U) VWF y = ordermap U VWF y"
   using y
 proof (induction rule: Ord_induct)
   case (step y)
   then have 1: "{u \<in> U. (u, y) \<in> VWF} = elts y \<inter> U"
     apply (simp add: set_eq_iff)
     by (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less assms subsetD)
   have 2: "{u \<in> insert \<alpha> U. (u, y) \<in> VWF} = elts y \<inter> U"
     apply (simp add: set_eq_iff)
     by (meson Ord_in_Ord Ord_mem_iff_lt VWF_iff_Ord_less assms leD step.hyps step.prems subsetD)
   show ?case
     using step
     apply (simp only: ordermap [OF wf_VWF, of _ y] 1 2)
     by (meson Int_lower1 Ord_is_Transset Sup.SUP_cong Transset_def assms(1) in_mono vsubsetD)
 qed
 
 lemma ordertype_insert:
   assumes "Ord \<alpha>" and U: "U \<subseteq> elts \<alpha>"
   shows "ordertype (insert \<alpha> U) VWF = succ (ordertype U VWF)"
 proof -
   have \<dagger>: "{y \<in> insert \<alpha> U. (y, \<alpha>) \<in> VWF} = U" "{y \<in> U. (y, \<alpha>) \<in> VWF} = U"
     using Ord_in_Ord OrdmemD assms by auto
   have eq: "\<And>x. x \<in> U \<Longrightarrow> ordermap (insert \<alpha> U) VWF x = ordermap U VWF x"
     by (meson Ord_in_Ord Ord_is_Transset Transset_def U assms(1) in_mono ordermap_insert)
   have "ordertype (insert \<alpha> U) VWF =
         ZFC_in_HOL.set (insert (ordermap U VWF \<alpha>) (ordermap U VWF ` U))"
     by (simp add: ordertype_def ordermap_insert assms eq)
   also have "\<dots> = succ (ZFC_in_HOL.set (ordermap U VWF ` U))"
     using "\<dagger>" U by (simp add: ordermap [OF wf_VWF, of _ \<alpha>] down succ_def vinsert_def)
   also have "\<dots> = succ (ordertype U VWF)"
     by (simp add: ordertype_def)
   finally show ?thesis .
 qed
 
 lemma finite_ordertype_le_card:
   assumes "finite A" "wf r" "trans r" 
   shows "ordertype A r \<le> ord_of_nat (card A)"
 proof -
   have "Ord (ordertype A r)"
     by (simp add: wf_Ord_ordertype assms)
   moreover have "ordermap A r ` A = elts (ordertype A r)"
     by (simp add: ordertype_def finite_imp_small \<open>finite A\<close>)
   moreover have "card (ordermap A r ` A) \<le> card A"
     using \<open>finite A\<close> card_image_le by blast
   ultimately show ?thesis
     by (metis Ord_linear_le Ord_ord_of_nat \<open>finite A\<close> card_ord_of_nat card_seteq finite_imageI less_eq_V_def)
 qed
 
 lemma ordertype_VWF_\<omega>:
   assumes "finite A"
   shows "ordertype A VWF \<in> elts \<omega>"
 proof -
   have "finite (ordermap A VWF ` A)"
     using assms by blast
   then have "ordertype A VWF < \<omega>"
     by (meson Ord_\<omega> OrdmemD trans_VWF wf_VWF assms finite_ordertype_le_card le_less_trans ord_of_nat_\<omega>)
   then show ?thesis
     by (simp add: Ord_mem_iff_lt)
 qed
 
 lemma ordertype_VWF_finite_nat:
   assumes "finite A"
   shows "ordertype A VWF = ord_of_nat (card A)"
   by (metis finite_imp_small ordermap_bij total_on_VWF wf_VWF \<omega>_def assms bij_betw_same_card card_ord_of_nat elts_of_set f_inv_into_f inf ordertype_VWF_\<omega>)
 
 lemma finite_ordertype_eq_card:
   assumes "small A" "wf r" "trans r" "total_on A r"
   shows "ordertype A r = ord_of_nat m \<longleftrightarrow> finite A \<and> card A = m"
   using ordermap_bij [OF \<open>wf r\<close>]
 proof -
   have *: "bij_betw (ordermap A r) A (elts (ordertype A r))"
     by (simp add: assms ordermap_bij)
   moreover have "card (ordermap A r ` A) = card A"
     by (meson bij_betw_def * card_image)
   ultimately show ?thesis
     using assms bij_betw_finite bij_betw_imp_surj_on finite_Ord_omega ordertype_VWF_finite_nat wf_Ord_ordertype by fastforce
 qed
 
 
 lemma ex_bij_betw_strict_mono_card:
   assumes "finite M" "M \<subseteq> ON"
   obtains h where "bij_betw h {..<card M} M" and "strict_mono_on h {..<card M}"
 proof -
   have bij: "bij_betw (ordermap M VWF) M (elts (card M))"
     using Finite_V \<open>finite M\<close> ordermap_bij ordertype_VWF_finite_nat by fastforce
   let ?h = "(inv_into M (ordermap M VWF)) \<circ> ord_of_nat"
   show thesis
   proof
     show bijh: "bij_betw ?h {..<card M} M"
     proof (rule bij_betw_trans)
       show "bij_betw ord_of_nat {..<card M} (elts (card M))"
         by (simp add: bij_betw_def elts_ord_of_nat inj_on_def)
       show "bij_betw (inv_into M (ordermap M VWF)) (elts (card M)) M"
         using Finite_V assms bij_betw_inv_into ordermap_bij ordertype_VWF_finite_nat by fastforce
     qed
     show "strict_mono_on ?h {..<card M}"
     proof -
       have "?h m < ?h n"
         if "m < n" "n < card M" for m n
       proof (rule ccontr)
         obtain mn: "m \<in> elts (ordertype M VWF)" "n \<in> elts (ordertype M VWF)"
           using \<open>m < n\<close> \<open>n < card M\<close> \<open>finite M\<close> ordertype_VWF_finite_nat by auto
         have ord: "Ord (?h m)" "Ord (?h n)"
           using bijh assms(2) bij_betwE that by fastforce+
         moreover
         assume "\<not> ?h m < ?h n"
         ultimately consider "?h m = ?h n" | "?h m > ?h n"
           using Ord_linear_lt by blast
         then show False
         proof cases
           case 1
           then have "m = n"
             by (metis inv_ordermap_mono_eq mn comp_apply ord_of_nat_inject)
           with \<open>m < n\<close> show False by blast 
         next
           case 2
           then have "ord_of_nat n \<le> ord_of_nat m"
             by (metis Finite_V mn assms comp_def inv_ordermap_VWF_mono_le less_imp_le)
           then show ?thesis
             using leD \<open>m < n\<close> by blast
         qed
       qed
       with assms show ?thesis
         by (auto simp: strict_mono_on_def)
     qed
   qed
 qed
 
 lemma ordertype_finite_less_than [simp]: 
   assumes "finite A" shows "ordertype A less_than = card A"
 proof -
   let ?M = "ord_of_nat ` A"
   obtain M: "finite ?M" "?M \<subseteq> ON"
     using Ord_ord_of_nat assms by blast
   have "ordertype A less_than = ordertype ?M VWF"
     by (rule ordertype_inc_eq [symmetric]) (use assms finite_imp_small total_on_def in \<open>force+\<close>)
   also have "\<dots> = card A"
   proof (subst ordertype_eq_iff)
     let ?M = "ord_of_nat ` A"
     obtain h where bijh: "bij_betw h {..<card A} ?M" and smh: "strict_mono_on h {..<card A}"
       by (metis M card_image ex_bij_betw_strict_mono_card inj_on_def ord_of_nat_inject)
     define f where "f \<equiv> ord_of_nat \<circ> inv_into {..<card A} h"
     show "\<exists>f. bij_betw f ?M (elts (card A)) \<and> (\<forall>x\<in>?M. \<forall>y\<in>?M. f x < f y \<longleftrightarrow> ((x, y) \<in> VWF))"
     proof (intro exI conjI ballI)
       have "bij_betw (ord_of_nat \<circ> inv_into {..<card A} h) (ord_of_nat ` A) (ord_of_nat ` {..<card A})"
         by (meson UNIV_I bijh bij_betw_def bij_betw_inv_into bij_betw_subset bij_betw_trans inj_ord_of_nat subsetI)
       then show "bij_betw f ?M (elts (card A))"
         by (metis elts_ord_of_nat f_def)
     next
       fix x y
       assume xy: "x \<in> ?M" "y \<in> ?M"
       then obtain m n where "x = ord_of_nat m" "y = ord_of_nat n"
         by auto
       have "(f x < f y) \<longleftrightarrow> ((h \<circ> inv_into {..<card A} h) x < (h \<circ> inv_into {..<card A} h) y)"
         unfolding f_def using smh bij_betw_imp_surj_on [OF bijh] 
         apply simp
         by (metis (mono_tags, lifting) inv_into_into not_less_iff_gr_or_eq order.asym strict_mono_onD xy)
       also have "\<dots> = (x < y)"
         using bijh
         by (simp add: bij_betw_inv_into_right xy)
       also have "\<dots> \<longleftrightarrow> ((x, y) \<in> VWF)"
         using M(2) ON_imp_Ord xy by auto
       finally show "(f x < f y) \<longleftrightarrow> ((x, y) \<in> VWF)" . 
     qed 
   qed auto
   finally show ?thesis .
 qed
 
 
 subsection\<open>Cardinality of a set\<close>
 
-definition
-  vcard :: "V\<Rightarrow>V"
+definition vcard :: "V\<Rightarrow>V"
   where "vcard a \<equiv> (LEAST i. Ord i \<and> elts i \<approx> elts a)"
 
-definition
-  Card:: "V\<Rightarrow>bool" where "Card i \<equiv> i = vcard i"
+definition Card:: "V\<Rightarrow>bool"
+  where "Card i \<equiv> i = vcard i"
 
 abbreviation CARD where "CARD \<equiv> Collect Card"
 
 lemma cardinal_cong: "elts x \<approx> elts y \<Longrightarrow> vcard x = vcard y"
   unfolding vcard_def by (meson eqpoll_sym eqpoll_trans)
 
 lemma Card_cardinal_eq: "Card \<kappa> \<Longrightarrow> vcard \<kappa> = \<kappa>"
   by (simp add: Card_def)
 
 lemma Card_is_Ord:
   assumes "Card \<kappa>" shows "Ord \<kappa>"
 proof -
   obtain \<alpha> where "Ord \<alpha>" "elts \<alpha> \<approx> elts \<kappa>"
     using Ord_ordertype ordertype_eqpoll by blast
   then have "Ord (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)"
     by (metis Ord_Least)
   then show ?thesis
     using Card_def vcard_def assms by auto
 qed
 
 lemma cardinal_eqpoll: "elts (vcard a) \<approx> elts a"
   unfolding vcard_def
   using ordertype_eqpoll [of "elts a"] Ord_LeastI by (meson Ord_ordertype small_elts)
 
 lemma inj_into_vcard:
   obtains f where "f \<in> elts A \<rightarrow> elts (vcard A)" "inj_on f (elts A)"
   using cardinal_eqpoll [of A] inj_on_the_inv_into the_inv_into_onto
   by (fastforce simp: Pi_iff bij_betw_def eqpoll_def)
 
 lemma cardinal_idem [simp]: "vcard (vcard a) = vcard a"
   using cardinal_cong cardinal_eqpoll by blast
 
 text\<open>every natural number is a (finite) cardinal\<close>
 lemma nat_into_Card:
   assumes "\<alpha> \<in> elts \<omega>" shows "Card(\<alpha>)"
 proof (unfold Card_def vcard_def, rule sym)
   obtain n where n: "\<alpha> = ord_of_nat n"
     by (metis \<omega>_def assms elts_of_set imageE inf)
   have "Ord(\<alpha>)" using assms by auto
   moreover
   { fix \<beta>
     assume "\<beta> < \<alpha>" "Ord \<beta>" "elts \<beta> \<approx> elts \<alpha>"
     with n have "elts \<beta> \<approx> {..<n}"
       by (simp add: ord_of_nat_eq_initial [of n] eqpoll_trans inj_on_def inj_on_image_eqpoll_self)
     hence False using assms n  \<open>Ord \<beta>\<close> \<open>\<beta> < \<alpha>\<close> \<open>Ord(\<alpha>)\<close>
       by (metis \<open>elts \<beta> \<approx> elts \<alpha>\<close> card_seteq eqpoll_finite_iff eqpoll_iff_card finite_lessThan less_eq_V_def less_le_not_le order_refl)
   }
   ultimately
     show "(LEAST i. Ord i \<and> elts i \<approx> elts \<alpha>) = \<alpha>"
       by (metis (no_types, lifting) Least_equality Ord_linear_le eqpoll_refl less_le_not_le)
   qed
 
 lemma Card_ord_of_nat [simp]: "Card (ord_of_nat n)"
   by (simp add: \<omega>_def nat_into_Card)
 
 lemma Card_0 [iff]: "Card 0"
   by (simp add: nat_into_Card)
 
 lemma CardI: "\<lbrakk>Ord i; \<And>j. \<lbrakk>j < i; Ord j\<rbrakk> \<Longrightarrow> \<not> elts j \<approx> elts i\<rbrakk> \<Longrightarrow> Card i"
   unfolding Card_def vcard_def
   by (metis Ord_Least Ord_linear_lt cardinal_eqpoll eqpoll_refl not_less_Ord_Least vcard_def)
 
 lemma vcard_0 [simp]: "vcard 0 = 0"
   using Card_0 Card_def by auto
 
 lemma Ord_cardinal [simp,intro!]: "Ord(vcard a)"
   unfolding vcard_def by (metis Card_def Card_is_Ord cardinal_cong cardinal_eqpoll vcard_def)
 
 text\<open>The cardinals are the initial ordinals.\<close>
 lemma Card_iff_initial: "Card \<kappa> \<longleftrightarrow> Ord \<kappa> \<and> (\<forall>\<alpha>. Ord \<alpha> \<and> \<alpha> < \<kappa> \<longrightarrow> ~ elts \<alpha> \<approx> elts \<kappa>)"
 proof -
   { fix j
     assume \<kappa>: "Card \<kappa>" "elts j \<approx> elts \<kappa>" "Ord j"
     assume "j < \<kappa>"
     also have "\<dots> = (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)" using \<kappa>
       by (simp add: Card_def vcard_def)
     finally have "j < (LEAST i. Ord i \<and> elts i \<approx> elts \<kappa>)" .
     hence "False" using \<kappa>
       using not_less_Ord_Least by fastforce
   }
   then show ?thesis
     by (blast intro: CardI Card_is_Ord)
 qed
 
 lemma Card_\<omega> [iff]: "Card \<omega>"
 proof -
   have "\<And>\<alpha> f. \<lbrakk>\<alpha> \<in> elts \<omega>; bij_betw f (elts \<alpha>) (elts \<omega>)\<rbrakk> \<Longrightarrow> False"
   using bij_betw_finite finite_Ord_omega infinite_\<omega> by blast
   then show ?thesis
     by (meson CardI Ord_\<omega> Ord_mem_iff_lt eqpoll_def)
 qed
 
 lemma lt_Card_imp_lesspoll: "\<lbrakk>i < a; Card a; Ord i\<rbrakk> \<Longrightarrow> elts i \<prec> elts a"
   by (meson Card_iff_initial less_eq_V_def less_imp_le lesspoll_def subset_imp_lepoll)
 
 lemma lepoll_imp_Card_le:
   assumes "elts a \<lesssim> elts b" shows "vcard a \<le> vcard b"
 using Ord_cardinal [of a] Ord_cardinal [of b]
 proof (cases rule: Ord_linear_le)
   case le thus ?thesis .
 next
   case ge
   have "elts b \<approx> elts (vcard b)"
     by (simp add: cardinal_eqpoll eqpoll_sym)
   also have "\<dots> \<lesssim> elts (vcard a)"
     by (meson ge less_eq_V_def subset_imp_lepoll)
   also have "\<dots> \<approx> elts a"
     by (simp add: cardinal_eqpoll)
   finally have "elts b \<lesssim> elts a"  .
   hence "elts a \<approx> elts b"
     using assms lepoll_antisym by blast
   hence "vcard a = vcard b"
     by (rule cardinal_cong)
   thus ?thesis by simp
 qed
 
 lemma lepoll_cardinal_le: "\<lbrakk>elts A \<lesssim> elts i; Ord i\<rbrakk> \<Longrightarrow> vcard A \<le> i"
   by (metis Ord_Least Ord_linear2 dual_order.trans eqpoll_refl lepoll_imp_Card_le not_less_Ord_Least vcard_def)
 
 lemma cardinal_le_lepoll: "vcard A \<le> \<alpha> \<Longrightarrow> elts A \<lesssim> elts \<alpha>"
   by (meson cardinal_eqpoll eqpoll_sym lepoll_trans1 less_eq_V_def subset_imp_lepoll)
 
 lemma lesspoll_imp_Card_less:
   assumes "elts a \<prec> elts b" shows "vcard a < vcard b"
   by (metis assms cardinal_eqpoll eqpoll_sym eqpoll_trans le_neq_trans lepoll_imp_Card_le lesspoll_def)
 
 
 lemma Card_Union [simp,intro]:
   assumes A: "\<And>x. x \<in> A \<Longrightarrow> Card(x)" shows "Card(\<Squnion>A)"
 proof (rule CardI)
   show "Ord(\<Squnion>A)" using A
     by (simp add: Card_is_Ord Ord_Sup)
 next
   fix j
   assume j: "j < \<Squnion>A" "Ord j"
   hence "\<exists>c\<in>A. j < c \<and> Card(c)" using A
     by (meson Card_is_Ord Ord_linear2 ZFC_in_HOL.Sup_least leD)
   then obtain c where c: "c\<in>A" "j < c" "Card(c)"
     by blast
   hence jls: "elts j \<prec> elts c"
     using j(2) lt_Card_imp_lesspoll by blast
   { assume eqp: "elts j \<approx> elts (\<Squnion>A)"
     have  "elts c \<lesssim> elts (\<Squnion>A)" using c
       using Sup_V_def ZFC_in_HOL.Sup_upper j(1) less_eq_V_def subset_imp_lepoll by fastforce
     also have "... \<approx> elts j"  by (rule eqpoll_sym [OF eqp])
     also have "... \<prec> elts c"  by (rule jls)
     finally have "elts c \<prec> elts c" .
     hence False
       by auto
   } thus "\<not> elts j \<approx> elts (\<Squnion>A)" by blast
 qed
 
 lemma Card_UN: "(\<And>x. x \<in> A \<Longrightarrow> Card(K x)) ==> Card(Sup (K ` A))"
   by blast
 
 subsection\<open>Transfinite recursion for definitions based on the three cases of ordinals\<close>
 
 definition
   transrec3 :: "[V, [V,V]\<Rightarrow>V, [V,V\<Rightarrow>V]\<Rightarrow>V, V] \<Rightarrow> V" where
     "transrec3 a b c \<equiv>
        transrec (\<lambda>r x.
          if x=0 then a
          else if Limit x then c x (\<lambda>y \<in> elts x. r y)
          else b(pred x) (r (pred x)))"
 
 lemma transrec3_0 [simp]: "transrec3 a b c 0 = a"
   by (simp add: transrec transrec3_def)
 
 lemma transrec3_succ [simp]:
      "transrec3 a b c (succ i) = b i (transrec3 a b c i)"
   by (simp add: transrec transrec3_def)
 
 lemma transrec3_Limit [simp]:
      "Limit i \<Longrightarrow>  transrec3 a b c i = c i (\<lambda>j \<in> elts i. transrec3 a b c j)"
   unfolding transrec3_def
   by (subst transrec) auto
 
 
 subsection \<open>Cardinal Addition\<close>
 
 definition cadd :: "[V,V]\<Rightarrow>V"       (infixl \<open>\<oplus>\<close> 65)
   where "\<kappa> \<oplus> \<mu> \<equiv> vcard (\<kappa> \<Uplus> \<mu>)"
 
 subsubsection\<open>Cardinal addition is commutative\<close>
 
 lemma vsum_commute_eqpoll: "elts (a\<Uplus>b) \<approx> elts (b\<Uplus>a)"
 proof -
   have "bij_betw (\<lambda>z \<in> elts (a\<Uplus>b). sum_case Inr Inl z) (elts (a\<Uplus>b)) (elts (b\<Uplus>a))"
     unfolding bij_betw_def
   proof (intro conjI inj_onI)
     show "restrict (sum_case Inr Inl) (elts (a \<Uplus> b)) ` elts (a \<Uplus> b) = elts (b \<Uplus> a)"
      apply auto
      apply (metis (no_types) imageI sum_case_Inr sum_iff)
       by (metis Inl_in_sum_iff imageI sum_case_Inl)
   qed auto
   then show ?thesis
     using eqpoll_def by blast
 qed
 
 lemma cadd_commute: "i \<oplus> j = j \<oplus> i"
   by (simp add: cadd_def cardinal_cong vsum_commute_eqpoll)
 
 subsubsection\<open>Cardinal addition is associative\<close>
 
 lemma sum_assoc_bij:
   "bij_betw (\<lambda>z \<in> elts ((a\<Uplus>b)\<Uplus>c). sum_case(sum_case Inl (\<lambda>y. Inr(Inl y))) (\<lambda>y. Inr(Inr y)) z)
       (elts ((a\<Uplus>b)\<Uplus>c)) (elts (a\<Uplus>(b\<Uplus>c)))"
   by (rule_tac f' = "sum_case (\<lambda>x. Inl (Inl x)) (sum_case (\<lambda>x. Inl (Inr x)) Inr)"
       in bij_betw_byWitness) auto
 
 lemma sum_assoc_eqpoll: "elts ((a\<Uplus>b)\<Uplus>c) \<approx> elts (a\<Uplus>(b\<Uplus>c))"
   unfolding eqpoll_def by (metis sum_assoc_bij)
 
 lemma elts_vcard_vsum_eqpoll: "elts (vcard (i \<Uplus> j)) \<approx> Inl ` elts i \<union> Inr ` elts j"
 proof -
   have "elts (i \<Uplus> j) \<approx> Inl ` elts i \<union> Inr ` elts j"
     by (simp add: elts_vsum)
   then show ?thesis
     using cardinal_eqpoll eqpoll_trans by blast
 qed
 
 lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
 proof (unfold cadd_def, rule cardinal_cong)
   have "elts (vcard(i \<Uplus> j) \<Uplus> k) \<approx> elts ((i \<Uplus> j) \<Uplus> k)"
     by (auto simp: disjnt_def elts_vsum elts_vcard_vsum_eqpoll intro: Un_eqpoll_cong)
   also have "\<dots>  \<approx> elts (i \<Uplus> (j \<Uplus> k))"
     by (rule sum_assoc_eqpoll)
   also have "\<dots>  \<approx> elts (i \<Uplus> vcard(j \<Uplus> k))"
     by (auto simp: disjnt_def elts_vsum elts_vcard_vsum_eqpoll [THEN eqpoll_sym] intro: Un_eqpoll_cong)
   finally show "elts (vcard (i \<Uplus> j) \<Uplus> k) \<approx> elts (i \<Uplus> vcard (j \<Uplus> k))" .
 qed
 
 
 text\<open>0 is the identity for addition\<close>
 lemma vsum_0_eqpoll: "elts (0\<Uplus>a) \<approx> elts a"
   by (simp add: elts_vsum)
 
 lemma cadd_0 [simp]: "Card \<kappa> \<Longrightarrow> 0 \<oplus> \<kappa> = \<kappa>"
   by (metis Card_def cadd_def cardinal_cong vsum_0_eqpoll)
 
 lemma cadd_0_right [simp]: "Card \<kappa> \<Longrightarrow> \<kappa> \<oplus> 0 = \<kappa>"
   by (simp add: cadd_commute)
 
 lemma vsum_lepoll_self: "elts a \<lesssim> elts (a\<Uplus>b)"
   unfolding elts_vsum  by (meson Inl_iff Un_upper1 inj_onI lepoll_def)
 
 lemma cadd_le_self:
   assumes \<kappa>: "Card \<kappa>" shows "\<kappa> \<le> \<kappa> \<oplus> a"
 proof (unfold cadd_def)
   have "\<kappa> \<le> vcard \<kappa>"
     using Card_def \<kappa> by auto
   also have "\<dots> \<le> vcard (\<kappa> \<Uplus> a)"
     by (simp add: lepoll_imp_Card_le vsum_lepoll_self)
   finally show "\<kappa> \<le> vcard (\<kappa> \<Uplus> a)" .
 qed
 
 text\<open>Monotonicity of addition\<close>
 lemma cadd_le_mono: "\<lbrakk>\<kappa>' \<le> \<kappa>; \<mu>' \<le> \<mu>\<rbrakk> \<Longrightarrow> \<kappa>' \<oplus> \<mu>' \<le> \<kappa> \<oplus> \<mu>"
   unfolding cadd_def
   by (metis (no_types) lepoll_imp_Card_le less_eq_V_def subset_imp_lepoll sum_subset_iff)
 
 subsection\<open>Cardinal multiplication\<close>
 
 definition cmult :: "[V,V]\<Rightarrow>V"       (infixl \<open>\<otimes>\<close> 70)
   where "\<kappa> \<otimes> \<mu> \<equiv> vcard (VSigma \<kappa> (\<lambda>z. \<mu>))"
 
 subsubsection\<open>Cardinal multiplication is commutative\<close>
 
 lemma prod_bij: "\<lbrakk>bij_betw f A C; bij_betw g B D\<rbrakk>
              \<Longrightarrow> bij_betw (\<lambda>(x, y). (f x, g y)) (A \<times> B) (C \<times> D)"
   apply (rule bij_betw_byWitness [where f' = "\<lambda>(x,y). (inv_into A f x, inv_into B g y)"])
      apply (auto simp: bij_betw_inv_into_left bij_betw_inv_into_right bij_betwE)
   using bij_betwE bij_betw_inv_into apply blast+
   done
 
 lemma cmult_commute: "i \<otimes> j = j \<otimes> i"
 proof -
   have "(\<lambda>(x, y). \<langle>x, y\<rangle>) ` (elts i \<times> elts j) \<approx> (\<lambda>(x, y). \<langle>x, y\<rangle>) ` (elts j \<times> elts i)"
     by (simp add: inj_on_vpair times_commute_eqpoll)
   then show ?thesis
     unfolding cmult_def
     using cardinal_cong elts_VSigma by auto
 qed
 
 subsubsection\<open>Cardinal multiplication is associative\<close>
 
 lemma elts_vcard_VSigma_eqpoll: "elts (vcard (vtimes i j)) \<approx> elts i \<times> elts j"
 proof -
   have "elts (vtimes i j) \<approx> elts i \<times> elts j"
     by (simp add: elts_VSigma)
   then show ?thesis
     using cardinal_eqpoll eqpoll_trans by blast
 qed
 
 lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
   unfolding cmult_def
 proof (rule cardinal_cong)
   have "elts (vcard (vtimes i j)) \<times> elts k \<approx> (elts i \<times> elts j) \<times> elts k"
     by (blast intro: times_eqpoll_cong elts_vcard_VSigma_eqpoll cardinal_eqpoll)
   also have "\<dots>  \<approx> elts i \<times> (elts j \<times> elts k)"
     by (rule times_assoc_eqpoll)
   also have "\<dots>  \<approx> elts i \<times> elts (vcard (vtimes j k))"
     by (blast intro: times_eqpoll_cong elts_vcard_VSigma_eqpoll cardinal_eqpoll eqpoll_sym)
   finally show "elts (VSigma (vcard (vtimes i j)) (\<lambda>z. k)) \<approx> elts (VSigma i (\<lambda>z. vcard (vtimes j k)))"
     by (simp add: elts_VSigma)
 qed
 
 subsubsection\<open>Cardinal multiplication distributes over addition\<close>
 
 lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
   unfolding cadd_def cmult_def
 proof (rule cardinal_cong)
 have "elts (vtimes (vcard (i \<Uplus> j)) k) \<approx> elts (vcard (vsum i j)) \<times> elts k"
   using cardinal_eqpoll elts_vcard_VSigma_eqpoll eqpoll_sym eqpoll_trans by blast
   also have "\<dots> \<approx> (Inl ` elts i \<union> Inr ` elts j) \<times> elts k"
     using elts_vcard_vsum_eqpoll times_eqpoll_cong by blast
   also have "\<dots> \<approx> (Inl ` elts i) \<times> elts k \<union> (Inr ` elts j) \<times> elts k"
     by (simp add: Sigma_Un_distrib1)
   also have "\<dots>  \<approx> elts (vtimes i k \<Uplus> vtimes j k)"
     unfolding Plus_def
     by (auto simp: elts_vsum elts_VSigma disjnt_iff intro!: Un_eqpoll_cong times_eqpoll_cong)
   also have "\<dots>  \<approx> elts (vcard (vtimes i k \<Uplus> vtimes j k))"
     by (simp add: cardinal_eqpoll eqpoll_sym)
   also have "\<dots>  \<approx> elts (vcard (vtimes i k) \<Uplus> vcard (vtimes j k))"
     by (metis cadd_assoc cadd_def cardinal_cong cardinal_eqpoll vsum_0_eqpoll vsum_commute_eqpoll)
   finally show "elts (VSigma (vcard (i \<Uplus> j)) (\<lambda>z. k))
              \<approx> elts (vcard (vtimes i k) \<Uplus> vcard (vtimes j k))" .
 qed
 
 text\<open>Multiplication by 0 yields 0\<close>
 lemma cmult_0 [simp]: "0 \<otimes> i = 0"
   using Card_0 Card_def cmult_def by auto
 
 text\<open>1 is the identity for multiplication\<close>
 lemma cmult_1 [simp]: assumes "Card \<kappa>" shows "1 \<otimes> \<kappa> = \<kappa>"
 proof -
   have "elts (vtimes (set {0}) \<kappa>) \<approx> elts \<kappa>"
     by (auto simp: elts_VSigma intro!: times_singleton_eqpoll)
   then show ?thesis
     by (metis Card_def assms cardinal_cong cmult_def elts_1 set_of_elts)
 qed
 
 subsection\<open>Some inequalities for multiplication\<close>
 
 lemma cmult_square_le: assumes "Card \<kappa>" shows "\<kappa> \<le> \<kappa> \<otimes> \<kappa>"
 proof -
   have "elts \<kappa> \<lesssim> elts (\<kappa> \<otimes> \<kappa>)"
     using times_square_lepoll [of "elts \<kappa>"] cmult_def elts_vcard_VSigma_eqpoll eqpoll_sym lepoll_trans2
     by fastforce
   then show ?thesis
     using Card_def assms cmult_def lepoll_cardinal_le by fastforce
 qed
 
 text\<open>Multiplication by a non-empty set\<close>
 lemma cmult_le_self: assumes "Card \<kappa>" "\<alpha> \<noteq> 0" shows "\<kappa> \<le> \<kappa> \<otimes> \<alpha>"
 proof -
   have "\<kappa> = vcard \<kappa>"
     using Card_def \<open>Card \<kappa>\<close> by blast
   also have "\<dots> \<le> vcard (vtimes \<kappa> \<alpha>)"
     apply (rule lepoll_imp_Card_le)
     apply (simp add: elts_VSigma)
     by (metis ZFC_in_HOL.ext \<open>\<alpha> \<noteq> 0\<close> elts_0 lepoll_times1)
   also have "\<dots> = \<kappa> \<otimes> \<alpha>"
     by (simp add: cmult_def)
   finally show ?thesis .
 qed
 
 
 text\<open>Monotonicity of multiplication\<close>
 lemma cmult_le_mono: "\<lbrakk>\<kappa>' \<le> \<kappa>; \<mu>' \<le> \<mu>\<rbrakk> \<Longrightarrow> \<kappa>' \<otimes> \<mu>' \<le> \<kappa> \<otimes> \<mu>"
   unfolding cmult_def
   by (auto simp: elts_VSigma intro!: lepoll_imp_Card_le times_lepoll_mono subset_imp_lepoll)
 
 
 subsection\<open>The finite cardinals\<close>
 
 lemma succ_lepoll_succD: "elts (succ(m)) \<lesssim> elts (succ(n)) \<Longrightarrow> elts m \<lesssim> elts n"
   by (simp add: insert_lepoll_insertD)
 
 
 text\<open>Congruence law for @{text succ} under equipollence\<close>
 lemma succ_eqpoll_cong: "elts a \<approx> elts b \<Longrightarrow> elts (succ(a)) \<approx> elts (succ(b))"
   by (simp add: succ_def insert_eqpoll_cong)
 
 lemma sum_succ_eqpoll: "elts (succ a \<Uplus> b) \<approx> elts (succ(a\<Uplus>b))"
   unfolding eqpoll_def
 proof (rule exI)
   let ?f = "\<lambda>z. if z=Inl a then a\<Uplus>b else z"
   let ?g = "\<lambda>z. if z=a\<Uplus>b then Inl a else z"
   show "bij_betw ?f (elts (succ a \<Uplus> b)) (elts (succ (a \<Uplus> b)))"
     apply (rule bij_betw_byWitness [where f' = ?g], auto)
      apply (metis Inl_in_sum_iff mem_not_refl)
     by (metis Inr_in_sum_iff mem_not_refl)
 qed
 
 lemma cadd_succ: "succ m \<oplus> n = vcard (succ(m \<oplus> n))"
 proof (unfold cadd_def)
   have [intro]: "elts (m \<Uplus> n) \<approx> elts (vcard (m \<Uplus> n))"
     using cardinal_eqpoll eqpoll_sym by blast
   have "vcard (succ m \<Uplus> n) = vcard (succ(m \<Uplus> n))"
     by (rule sum_succ_eqpoll [THEN cardinal_cong])
   also have "\<dots> = vcard (succ(vcard (m \<Uplus> n)))"
     by (blast intro: succ_eqpoll_cong cardinal_cong)
   finally show "vcard (succ m \<Uplus> n) = vcard (succ(vcard (m \<Uplus> n)))" .
 qed
 
 lemma nat_cadd_eq_add: "ord_of_nat m \<oplus> ord_of_nat n = ord_of_nat (m + n)"
 proof (induct m)
   case (Suc m) thus ?case
     by (metis Card_def Card_ord_of_nat add_Suc cadd_succ ord_of_nat.simps(2))
 qed auto
 
 lemma vcard_disjoint_sup:
   assumes "x \<sqinter> y = 0" shows "vcard (x \<squnion> y) = vcard x \<oplus> vcard y"
 proof -
   have "elts (x \<squnion> y) \<approx> elts (x \<Uplus> y)"
     unfolding eqpoll_def
   proof (rule exI)
     let ?f = "\<lambda>z. if z \<in> elts x then Inl z else Inr z"
     let ?g = "sum_case id id"
     show "bij_betw ?f (elts (x \<squnion> y)) (elts (x \<Uplus> y))"
       by (rule bij_betw_byWitness [where f' = ?g]) (use assms V_disjoint_iff in auto)
   qed
   then show ?thesis
     by (metis cadd_commute cadd_def cardinal_cong cardinal_idem vsum_0_eqpoll cadd_assoc)
 qed
 
 
 subsection\<open>Infinite cardinals\<close>
 
 definition InfCard :: "V\<Rightarrow>bool"
   where "InfCard \<kappa> \<equiv> Card \<kappa> \<and> \<omega> \<le> \<kappa>"
 
 lemma InfCard_iff: "InfCard \<kappa> \<longleftrightarrow> Card \<kappa> \<and> infinite (elts \<kappa>)"
 proof (cases "\<omega> \<le> \<kappa>")
   case True
   then show ?thesis
     using inj_ord_of_nat lepoll_def less_eq_V_def
     by (auto simp: InfCard_def \<omega>_def infinite_le_lepoll)
 next
   case False
   then show ?thesis
     using Card_iff_initial InfCard_def infinite_Ord_omega by blast
 qed
 
 lemma InfCard_ge_ord_of_nat:
   assumes "InfCard \<kappa>" shows "ord_of_nat n \<le> \<kappa>"
   using InfCard_def assms ord_of_nat_le_omega by blast
 
 lemma InfCard_not_0[iff]: "\<not> InfCard 0"
   by (simp add: InfCard_iff)
 
-definition
-  csucc :: "V\<Rightarrow>V"
+definition csucc :: "V\<Rightarrow>V"
   where "csucc \<kappa> \<equiv> LEAST \<kappa>'. Ord \<kappa>' \<and> (Card \<kappa>' \<and> \<kappa> < \<kappa>')"
 
 
 lemma less_vcard_VPow: "vcard A < vcard (VPow A)"
 proof (rule lesspoll_imp_Card_less)
   show "elts A \<prec> elts (VPow A)"
     by (simp add: elts_VPow down inj_on_def lesspoll_Pow_self)
 qed
 
 lemma greater_Card:
   assumes "Card \<kappa>" shows "\<kappa> < vcard (VPow \<kappa>)"
 proof -
   have "\<kappa> = vcard \<kappa>"
     using Card_def assms by blast
   also have "\<dots> < vcard (VPow \<kappa>)"
   proof (rule lesspoll_imp_Card_less)
     show "elts \<kappa> \<prec> elts (VPow \<kappa>)"
       by (simp add: elts_VPow down inj_on_def lesspoll_Pow_self)
   qed
   finally show ?thesis .
 qed
 
 lemma
   assumes "Card \<kappa>"
   shows Card_csucc [simp]: "Card (csucc \<kappa>)" and less_csucc [simp]: "\<kappa> < csucc \<kappa>"
 proof -
   have "Card (csucc \<kappa>) \<and> \<kappa> < csucc \<kappa>"
     unfolding csucc_def
   proof (rule Ord_LeastI2)
     show "Card (vcard (VPow \<kappa>)) \<and> \<kappa> < (vcard (VPow \<kappa>))"
       using Card_def assms greater_Card by auto
   qed auto
   then show "Card (csucc \<kappa>)" "\<kappa> < csucc \<kappa>"
     by auto
 qed
 
 lemma le_csucc:
   assumes "Card \<kappa>" shows "\<kappa> \<le> csucc \<kappa>"
   by (simp add: assms less_csucc less_imp_le)
 
 
 lemma csucc_le: "\<lbrakk>Card \<mu>; \<kappa> \<in> elts \<mu>\<rbrakk> \<Longrightarrow> csucc \<kappa> \<le> \<mu>"
   unfolding csucc_def
   by (simp add: Card_is_Ord Ord_Least_le OrdmemD)
 
 lemma finite_csucc: "a \<in> elts \<omega> \<Longrightarrow> csucc a = succ a"
   unfolding csucc_def
   proof (rule Least_equality)
   show "Ord (ZFC_in_HOL.succ a) \<and> Card (ZFC_in_HOL.succ a) \<and> a < ZFC_in_HOL.succ a"
     if "a \<in> elts \<omega>"
     using that by (auto simp: less_V_def less_eq_V_def nat_into_Card)
   show "ZFC_in_HOL.succ a \<le> y"
     if "a \<in> elts \<omega>"
       and "Ord y \<and> Card y \<and> a < y"
     for y :: V
     using that
     using Ord_mem_iff_lt dual_order.strict_implies_order by fastforce
 qed
 
 lemma Finite_imp_cardinal_cons [simp]:
   assumes FA: "finite A" and a: "a \<notin> A"
   shows "vcard (set (insert a A)) = csucc(vcard (set A))"
 proof -
   show ?thesis
     unfolding csucc_def
   proof (rule Least_equality [THEN sym])
     have "small A"
       by (simp add: FA Finite_V)
     then have "\<not> elts (set A) \<approx> elts (set (insert a A))"
       using FA a eqpoll_imp_lepoll eqpoll_sym finite_insert_lepoll by fastforce
     then show "Ord (vcard (set (insert a A))) \<and> Card (vcard (set (insert a A))) \<and> vcard (set A) < vcard (set (insert a A))"
       by (simp add: Card_def lesspoll_imp_Card_less lesspoll_def subset_imp_lepoll subset_insertI)
     show "vcard (set (insert a A)) \<le> i"
       if "Ord i \<and> Card i \<and> vcard (set A) < i" for i
     proof -
       have "elts (vcard (set A)) \<approx> A"
         by (metis FA finite_imp_small cardinal_eqpoll elts_of_set)
       then have less: "A \<prec> elts i"
         using eq_lesspoll_trans eqpoll_sym lt_Card_imp_lesspoll that by blast
       show ?thesis
         using that less by (auto simp: less_imp_insert_lepoll lepoll_cardinal_le)
     qed
   qed
 qed
 
 lemma vcard_finite_set: "finite A \<Longrightarrow> vcard (set A) = ord_of_nat (card A)"
   by (induction A rule: finite_induct) (auto simp: set_empty \<omega>_def finite_csucc)
 
 lemma lt_csucc_iff:
   assumes "Ord \<alpha>" "Card \<kappa>"
   shows "\<alpha> < csucc \<kappa> \<longleftrightarrow> vcard \<alpha> \<le> \<kappa>"
 proof
   show "vcard \<alpha> \<le> \<kappa>" if "\<alpha> < csucc \<kappa>"
   proof -
     have "vcard \<alpha> \<le> csucc \<kappa>"
       by (meson \<open>Ord \<alpha>\<close> dual_order.trans lepoll_cardinal_le lepoll_refl less_le_not_le that)
     then show ?thesis
       by (metis (no_types) Card_def Card_iff_initial Ord_linear2 Ord_mem_iff_lt assms cardinal_eqpoll cardinal_idem csucc_le eq_iff eqpoll_sym that)
   qed
   show "\<alpha> < csucc \<kappa>" if "vcard \<alpha> \<le> \<kappa>"
   proof -
     have "\<not> csucc \<kappa> \<le> \<alpha>"
       using that
       by (metis Card_csucc Card_def assms(2) le_less_trans lepoll_imp_Card_le less_csucc less_eq_V_def less_le_not_le subset_imp_lepoll)
     then show ?thesis
       by (meson Card_csucc Card_is_Ord Ord_linear2 assms)
   qed
 qed
 
 lemma Card_lt_csucc_iff: "\<lbrakk>Card \<kappa>'; Card \<kappa>\<rbrakk> \<Longrightarrow> (\<kappa>' < csucc \<kappa>) = (\<kappa>' \<le> \<kappa>)"
   by (simp add: lt_csucc_iff Card_cardinal_eq Card_is_Ord)
 
 lemma InfCard_csucc: "InfCard \<kappa> \<Longrightarrow> InfCard (csucc \<kappa>)"
   using InfCard_def le_csucc by auto
 
 
 text\<open>Kunen's Lemma 10.11\<close>
 lemma InfCard_is_Limit:
   assumes "InfCard \<kappa>" shows "Limit \<kappa>"
   proof (rule non_succ_LimitI)
   show "\<kappa> \<noteq> 0"
     using InfCard_def assms mem_not_refl by blast
   show "Ord \<kappa>"
     using Card_is_Ord InfCard_def assms by blast
   show "ZFC_in_HOL.succ y \<noteq> \<kappa>" for y
   proof
     assume "succ y = \<kappa>"
     then have "Card (succ y)"
       using InfCard_def assms by auto
     moreover have "\<omega> \<le> y"
       by (metis InfCard_iff Ord_in_Ord \<open>Ord \<kappa>\<close> \<open>ZFC_in_HOL.succ y = \<kappa>\<close> assms elts_succ finite_insert infinite_Ord_omega insertI1)
     moreover have "elts y \<approx> elts (succ y)"
       using InfCard_iff \<open>ZFC_in_HOL.succ y = \<kappa>\<close> assms eqpoll_sym infinite_insert_eqpoll by fastforce
     ultimately show False
       by (metis Card_iff_initial Ord_in_Ord OrdmemD elts_succ insertI1)
   qed
 qed
 
 
 subsection\<open>Toward's Kunen's Corollary 10.13 (1)\<close>
 
 text\<open>Kunen's Theorem 10.12\<close>
 lemma InfCard_csquare_eq:
   assumes "InfCard(\<kappa>)" shows "\<kappa> \<otimes> \<kappa> = \<kappa>"
   using infinite_times_eqpoll_self [of "elts \<kappa>"] assms
   unfolding InfCard_iff Card_def
   by (metis cardinal_cong cardinal_eqpoll cmult_def elts_vcard_VSigma_eqpoll eqpoll_trans)
 
 lemma InfCard_le_cmult_eq:
   assumes "InfCard \<kappa>" "\<mu> \<le> \<kappa>" "\<mu> \<noteq> 0"
   shows "\<kappa> \<otimes> \<mu> = \<kappa>"
 proof (rule order_antisym)
   have "\<kappa> \<otimes> \<mu> \<le> \<kappa> \<otimes> \<kappa>"
     by (simp add: assms(2) cmult_le_mono)
   also have "\<dots> \<le> \<kappa>"
     by (simp add: InfCard_csquare_eq assms(1))
   finally show "\<kappa> \<otimes> \<mu> \<le> \<kappa>" .
   show "\<kappa> \<le> \<kappa> \<otimes> \<mu>"
     using InfCard_def assms(1) assms(3) cmult_le_self by auto
 qed
 
 text\<open>Kunen's Corollary 10.13 (1), for cardinal multiplication\<close>
 lemma InfCard_cmult_eq: "\<lbrakk>InfCard \<kappa>; InfCard \<mu>\<rbrakk> \<Longrightarrow> \<kappa> \<otimes> \<mu> = \<kappa> \<squnion> \<mu>"
   by (metis Card_is_Ord InfCard_def InfCard_le_cmult_eq Ord_linear_le cmult_commute inf_sup_aci(5) mem_not_refl sup.orderE sup_V_0_right zero_in_omega)
 
 lemma cmult_succ:
   "succ(m) \<otimes> n = n \<oplus> (m \<otimes> n)"
   unfolding cmult_def cadd_def
 proof (rule cardinal_cong)
   have "elts (vtimes (ZFC_in_HOL.succ m) n) \<approx> elts n <+> elts m \<times> elts n"
     by (simp add: elts_VSigma prod_insert_eqpoll)
   also have "\<dots> \<approx> elts (n \<Uplus> vcard (vtimes m n))"
     unfolding elts_VSigma elts_vsum Plus_def
   proof (rule Un_eqpoll_cong)
     show "(Sum_Type.Inr ` (elts m \<times> elts n)::(V + V \<times> V) set) \<approx> Inr ` elts (vcard (vtimes m n))"
       by (simp add: elts_vcard_VSigma_eqpoll eqpoll_sym)
   qed (auto simp: disjnt_def)
   finally show "elts (vtimes (ZFC_in_HOL.succ m) n) \<approx> elts (n \<Uplus> vcard (vtimes m n))" .
 qed
 
 lemma cmult_2:
   assumes "Card n" shows "ord_of_nat 2 \<otimes> n = n \<oplus> n"
 proof -
   have "ord_of_nat 2 = succ (succ 0)"
     by force
   then show ?thesis
     by (simp add: cmult_succ assms)
 qed
 
 lemma InfCard_cdouble_eq:
   assumes "InfCard \<kappa>" shows "\<kappa> \<oplus> \<kappa> = \<kappa>"
 proof -
   have "\<kappa> \<oplus> \<kappa> = \<kappa> \<otimes> ord_of_nat 2"
     using InfCard_def assms cmult_2 cmult_commute by auto
   also have "\<dots> = \<kappa>"
     by (simp add: InfCard_le_cmult_eq InfCard_ge_ord_of_nat assms)
   finally show ?thesis .
 qed
 
 text\<open>Corollary 10.13 (1), for cardinal addition\<close>
 lemma InfCard_le_cadd_eq: "\<lbrakk>InfCard \<kappa>; \<mu> \<le> \<kappa>\<rbrakk> \<Longrightarrow> \<kappa> \<oplus> \<mu> = \<kappa>"
   by (metis InfCard_cdouble_eq InfCard_def antisym cadd_le_mono cadd_le_self)
 
 lemma InfCard_cadd_eq: "\<lbrakk>InfCard \<kappa>; InfCard \<mu>\<rbrakk> \<Longrightarrow> \<kappa> \<oplus> \<mu> = \<kappa> \<squnion> \<mu>"
   by (metis Card_iff_initial InfCard_def InfCard_le_cadd_eq Ord_linear_le cadd_commute sup.absorb2 sup.orderE)
 
 
 subsection \<open>The Aleph-seqence\<close>
 
 text \<open>This is the well-known transfinite enumeration of the cardinal numbers.\<close>
 
-definition
-  Aleph :: "V \<Rightarrow> V"   (\<open>\<aleph>_\<close> [90] 90) 
+definition Aleph :: "V \<Rightarrow> V"   (\<open>\<aleph>_\<close> [90] 90) 
   where "Aleph \<equiv> transrec3 \<omega> (\<lambda>x r. csucc(r)) (\<lambda>i r . \<Squnion> (r ` elts i))"
 
 lemma Card_Aleph [simp, intro]:
      "Ord \<alpha> \<Longrightarrow> Card(Aleph \<alpha>)"
 by (induction \<alpha> rule: Ord_induct3) (auto simp: Aleph_def)
 
 lemma Aleph_0 [simp]: "\<aleph>0 = \<omega>"
   by (simp add: Aleph_def)
 
 lemma Aleph_succ [simp]: "\<aleph>(succ x) = csucc (\<aleph> x)"
   by (simp add: Aleph_def)
 
 lemma Aleph_Limit: "Limit \<gamma> \<Longrightarrow> \<aleph> \<gamma> = \<Squnion> (Aleph ` elts \<gamma>)"
   by (simp add: Aleph_def)
 
 lemma mem_Aleph_succ: "Ord \<alpha> \<Longrightarrow> \<aleph>(\<alpha>) \<in> elts (\<aleph>(succ \<alpha>))"
   by (simp add: Card_is_Ord Ord_mem_iff_lt)
 
 lemma Aleph_increasing:
   assumes ab: "\<alpha> < \<beta>" "Ord \<alpha>" "Ord \<beta>" shows "Aleph(\<alpha>) < Aleph(\<beta>)"
 proof -
   { fix x
     have "\<lbrakk>Ord x; x \<in> elts \<beta>\<rbrakk> \<Longrightarrow> Aleph(x) \<in> elts (Aleph \<beta>)"
       using \<open>Ord \<beta>\<close>
     proof (induct \<beta> arbitrary: x rule: Ord_induct3)
       case 0 thus ?case by simp
     next
       case (succ \<beta>)
       then consider "x = \<beta>" |"x \<in> elts \<beta>"
         using OrdmemD by auto
       then show ?case
       proof cases
         case 1
         then show ?thesis
           by (simp add: Card_is_Ord Ord_mem_iff_lt succ.hyps(1))
       next
         case 2
         with succ show ?thesis
           by (metis Aleph_succ Card_Aleph le_csucc vsubsetD)
       qed
     next
       case (Limit \<gamma>)
       hence sc: "succ x \<in> elts \<gamma>"
         by (simp add: Limit_def Ord_mem_iff_lt)
       hence "\<aleph> x \<in> elts (\<Squnion> (Aleph ` elts \<gamma>))" 
         using Limit
         by blast
       thus ?case using Limit
         by (simp add: Aleph_Limit)
     qed
   } thus ?thesis using ab
     by (simp add: Card_is_Ord Ord_mem_iff_lt)
 qed
 
 lemma countable_iff_le_Aleph0: "countable (elts A) \<longleftrightarrow> vcard A \<le> \<aleph>0"
 proof
   show "vcard A \<le> \<aleph>0"
     if "countable (elts A)"
   proof (cases "finite (elts A)")
     case True
     then show ?thesis
       using vcard_finite_set by fastforce
   next
     case False
     then have "elts \<omega> \<approx> elts A"
       using countableE_infinite [OF that]     
       by (simp add: eqpoll_def \<omega>_def) (meson bij_betw_def bij_betw_inv bij_betw_trans inj_ord_of_nat)
     then show ?thesis
       using Card_\<omega> Card_def cardinal_cong vcard_def by auto
   qed
   show "countable (elts A)"
     if "vcard A \<le> \<aleph>0"
   proof -
     have "elts A \<lesssim> elts \<omega>"
       using cardinal_le_lepoll [OF that] by simp
     then show ?thesis
       by (simp add: countable_iff_lepoll \<omega>_def inj_ord_of_nat)
   qed
 qed
 
 subsection \<open>The ordinal @{term "\<omega>1"}\<close>
 
 abbreviation "\<omega>1 \<equiv> Aleph 1"
 
 lemma Ord_\<omega>1 [simp]: "Ord \<omega>1"
   by (simp add: Card_is_Ord)
 
 lemma omega_\<omega>1 [iff]: "\<omega> \<in> elts \<omega>1"
   using mem_Aleph_succ one_V_def by fastforce
 
 lemma ord_of_nat_\<omega>1 [iff]: "ord_of_nat n \<in> elts \<omega>1"
   using Ord_\<omega>1 Ord_trans by blast
 
 lemma countable_iff_less_\<omega>1:
   assumes "Ord \<alpha>"
   shows "countable (elts \<alpha>) \<longleftrightarrow> \<alpha> < \<omega>1"
   by (simp add: assms countable_iff_le_Aleph0 lt_csucc_iff one_V_def)
 
 lemma less_\<omega>1_imp_countable:
   assumes "\<alpha> \<in> elts \<omega>1"
   shows "countable (elts \<alpha>)"
   using Ord_\<omega>1 Ord_in_Ord OrdmemD assms countable_iff_less_\<omega>1 by blast
 
 lemma \<omega>1_gt0 [simp]: "\<omega>1 > 0"
   using Ord_\<omega>1 Ord_trans OrdmemD by blast
 
 lemma \<omega>1_gt1 [simp]: "\<omega>1 > 1"
   using Ord_\<omega>1 OrdmemD \<omega>_gt1 less_trans by blast
 
 lemma Limit_\<omega>1 [simp]: "Limit \<omega>1"
   by (simp add: InfCard_def InfCard_is_Limit le_csucc one_V_def)
 
 end
diff --git a/thys/ZFC_in_HOL/ZFC_in_HOL.thy b/thys/ZFC_in_HOL/ZFC_in_HOL.thy
--- a/thys/ZFC_in_HOL/ZFC_in_HOL.thy
+++ b/thys/ZFC_in_HOL/ZFC_in_HOL.thy
@@ -1,1293 +1,1290 @@
 section \<open>The ZF Axioms, Ordinals and Transfinite Recursion\<close>
 
 theory ZFC_in_HOL
   imports ZFC_Library
 
 begin
 
 subsection\<open>Syntax and axioms\<close>
 
 hide_const (open) list.set Sum subset
 
-notation
-  inf (infixl "\<sqinter>" 70) and
-  sup (infixl "\<squnion>" 65) and
-  Inf ("\<Sqinter>") and
-  Sup ("\<Squnion>")
+unbundle lattice_syntax
 
 typedecl V
 
 text\<open>Presentation refined by Dmitriy Traytel\<close>
 axiomatization elts :: "V \<Rightarrow> V set"
  where ext [intro?]:    "elts x = elts y \<Longrightarrow> x=y"
    and down_raw:        "Y \<subseteq> elts x \<Longrightarrow> Y \<in> range elts"
    and Union_raw:       "X \<in> range elts \<Longrightarrow> Union (elts ` X) \<in> range elts"
    and Pow_raw:         "X \<in> range elts \<Longrightarrow> inv elts ` Pow X \<in> range elts"
    and replacement_raw: "X \<in> range elts \<Longrightarrow> f ` X \<in> range elts"
    and inf_raw:         "range (g :: nat \<Rightarrow> V) \<in> range elts"
    and foundation:      "wf {(x,y). x \<in> elts y}"
 
 lemma mem_not_refl [simp]: "i \<notin> elts i"
   using wf_not_refl [OF foundation] by force
 
 lemma mem_not_sym: "\<not> (x \<in> elts y \<and> y \<in> elts x)"
   using wf_not_sym [OF foundation] by force
 
 text \<open>A set is small if it can be injected into the extension of a V-set.\<close>
 definition small :: "'a set \<Rightarrow> bool" 
   where "small X \<equiv> \<exists>V_of :: 'a \<Rightarrow> V. inj_on V_of X \<and> V_of ` X \<in> range elts"
 
 lemma small_empty [iff]: "small {}"
   by (simp add: small_def down_raw)
 
 lemma small_iff_range: "small X \<longleftrightarrow> X \<in> range elts"
   apply (simp add: small_def)
   by (metis inj_on_id2 replacement_raw the_inv_into_onto)
 
 text\<open>Small classes can be mapped to sets.\<close>
-definition   "set X \<equiv> (if small X then inv elts X else inv elts {})"
+definition set :: "V set \<Rightarrow> V"
+  where "set X \<equiv> (if small X then inv elts X else inv elts {})"
 
 lemma set_of_elts [simp]: "set (elts x) = x"
   by (force simp add: ext set_def f_inv_into_f small_def)
 
 lemma elts_of_set [simp]: "elts (set X) = (if small X then X else {})"
   by (simp add: ZFC_in_HOL.set_def down_raw f_inv_into_f small_iff_range)
 
 lemma down: "Y \<subseteq> elts x \<Longrightarrow> small Y"
   by (simp add: down_raw small_iff_range)
 
 lemma Union [intro]: "small X \<Longrightarrow> small (Union (elts ` X))"
   by (simp add: Union_raw small_iff_range)
 
 lemma Pow: "small X \<Longrightarrow> small (set ` Pow X)"
   unfolding small_iff_range using Pow_raw set_def down by force
 
 declare replacement_raw [intro,simp]
 
 lemma replacement [intro,simp]:
   assumes "small X"
   shows "small (f ` X)" 
 proof -
   let ?A = "inv_into X f ` (f ` X)"
   have AX: "?A \<subseteq> X"
     by (simp add: image_subsetI inv_into_into)
   have inj: "inj_on f ?A"
     by (simp add: f_inv_into_f inj_on_def)
   have injo: "inj_on (inv_into X f) (f ` X)"
     using inj_on_inv_into by blast
   have "\<exists>V_of. inj_on V_of (f ` X) \<and> V_of ` f ` X \<in> range elts"
     if "inj_on V_of X" and "V_of ` X = elts x"
     for V_of :: "'a \<Rightarrow> V" and x
   proof (intro exI conjI)
     show "inj_on (V_of \<circ> inv_into X f) (f ` X)"
       by (meson \<open>inv_into X f ` f ` X \<subseteq> X\<close> comp_inj_on inj_on_subset injo that)
     have "(\<lambda>x. V_of (inv_into X f (f x))) ` X = elts (set (V_of ` ?A))"
       by (metis AX down elts_of_set image_image image_mono that(2))
     then show "(V_of \<circ> inv_into X f) ` f ` X \<in> range elts"
       by (metis image_comp image_image rangeI)
   qed
   then show ?thesis
     using assms by (auto simp: small_def)
 qed
 
 lemma small_image_iff [simp]: "inj_on f A \<Longrightarrow> small (f ` A) \<longleftrightarrow> small A"
   by (metis replacement the_inv_into_onto)
 
 text \<open>A little bootstrapping is needed to characterise @{term small} for sets of arbitrary type.\<close>
 
 lemma inf: "small (range (g :: nat \<Rightarrow> V))"
   by (simp add: inf_raw small_iff_range)
 
 lemma small_image_nat_V [simp]: "small (g ` N)" for g :: "nat \<Rightarrow> V"
   by (metis (mono_tags, opaque_lifting) down elts_of_set image_iff inf rangeI subsetI)
 
 lemma Finite_V:
   fixes X :: "V set"
   assumes "finite X" shows "small X"
   using ex_bij_betw_nat_finite [OF assms] unfolding bij_betw_def by (metis small_image_nat_V)
 
 lemma small_insert_V:
   fixes X :: "V set"
   assumes "small X"
   shows "small (insert a X)"
 proof (cases "finite X")
   case True
   then show ?thesis
     by (simp add: Finite_V)
 next
   case False
   show ?thesis
     using infinite_imp_bij_betw2 [OF False]
     by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
 qed
 
 lemma small_UN_V [simp,intro]:
   fixes B :: "'a \<Rightarrow> V set"
   assumes X: "small X" and B: "\<And>x. x \<in> X \<Longrightarrow> small (B x)"
   shows "small (\<Union>x\<in>X. B x)"
 proof -
   have "(\<Union> (elts ` (\<lambda>x. ZFC_in_HOL.set (B x)) ` X)) = (\<Union> (B ` X))"
     using B by force
   then show ?thesis
     using Union [OF replacement [OF X, of "\<lambda>x. ZFC_in_HOL.set (B x)"]] by simp
 qed
  
 definition vinsert where "vinsert x y \<equiv> set (insert x (elts y))"
 
 lemma elts_vinsert [simp]: "elts (vinsert x y) = insert x (elts y)"
   using down small_insert_V vinsert_def by auto
 
 definition succ where "succ x \<equiv> vinsert x x"
 
 lemma elts_succ [simp]: "elts (succ x) = insert x (elts x)"
   by (simp add: succ_def)
 
 lemma finite_imp_small:
   assumes "finite X" shows "small X"
   using assms
 proof induction
   case empty
   then show ?case
     by simp
 next
   case (insert a X)
   then obtain V_of u where u: "inj_on V_of X" "V_of ` X = elts u"
     by (meson small_def image_iff)
   show ?case
     unfolding small_def
   proof (intro exI conjI)
     show "inj_on (V_of(a:=u)) (insert a X)"
       using u
       apply (clarsimp simp add: inj_on_def)
       by (metis image_eqI mem_not_refl)
     have "(V_of(a:=u)) ` insert a X = elts (vinsert u u)"
       using insert.hyps(2) u(2) by auto
     then show "(V_of(a:=u)) ` insert a X \<in> range elts"
       by (blast intro:  elim: )
   qed
 qed
 
 lemma small_insert:
   assumes "small X"
   shows "small (insert a X)"
 proof (cases "finite X")
   case True
   then show ?thesis
     by (simp add: finite_imp_small)
 next
   case False
   show ?thesis
     using infinite_imp_bij_betw2 [OF False]
     by (metis replacement Un_insert_right assms bij_betw_imp_surj_on sup_bot.right_neutral)
 qed
 
 lemma smaller_than_small:
   assumes "small A" "B \<subseteq> A" shows "small B"
   using assms
   by (metis down elts_of_set image_mono small_def small_iff_range subset_inj_on) 
 
 lemma small_insert_iff [iff]: "small (insert a X) \<longleftrightarrow> small X"
   by (meson small_insert smaller_than_small subset_insertI)
 
 lemma small_iff: "small X \<longleftrightarrow> (\<exists>x. X = elts x)"
   by (metis down elts_of_set subset_refl)
 
 lemma small_elts [iff]: "small (elts x)"
   by (auto simp: small_iff)
 
 lemma small_diff [iff]: "small (elts a - X)"
   by (meson Diff_subset down)
 
 lemma small_set [simp]: "small (list.set xs)"
   by (simp add: ZFC_in_HOL.finite_imp_small)
 
 lemma small_upair: "small {x,y}"
   by simp
 
 lemma small_Un_elts: "small (elts x \<union> elts y)"
   using Union [OF small_upair] by auto
 
 lemma small_eqcong: "\<lbrakk>small X; X \<approx> Y\<rbrakk> \<Longrightarrow> small Y"
   by (metis bij_betw_imp_surj_on eqpoll_def replacement)
 
 lemma big_UNIV [simp]: "\<not> small (UNIV::V set)" (is  "\<not> small ?U")
   proof
     assume "small ?U"
     then have "small A" for A :: "V set"
       by (metis (full_types) UNIV_I down small_iff subsetI)
     then have "range elts = UNIV"
       by (meson small_iff surj_def)
   then show False
     by (metis Cantors_paradox Pow_UNIV)
 qed
 
 lemma inj_on_set: "inj_on set (Collect small)"
   by (metis elts_of_set inj_onI mem_Collect_eq)
 
 lemma set_injective [simp]: "\<lbrakk>small X; small Y\<rbrakk> \<Longrightarrow> set X = set Y \<longleftrightarrow> X=Y"
   by (metis elts_of_set)
 
 
 subsection\<open>Type classes and other basic setup\<close>
 
 instantiation V :: zero
 begin
 definition zero_V where "0 \<equiv> set {}"
 instance ..
 end
 
 lemma elts_0 [simp]: "elts 0 = {}"
   by (simp add: zero_V_def)
 
 lemma set_empty [simp]: "set {} = 0"
   by (simp add: zero_V_def)
 
 instantiation V :: one
 begin
 definition one_V where "1 \<equiv> succ 0"
 instance ..
 end
 
 lemma elts_1 [simp]: "elts 1 = {0}"
   by (simp add: one_V_def)
 
 lemma insert_neq_0 [simp]: "set (insert a X) = 0 \<longleftrightarrow> \<not> small X"
   unfolding zero_V_def
   by (metis elts_of_set empty_not_insert set_of_elts small_insert_iff)
 
 lemma elts_eq_empty_iff [simp]: "elts x = {} \<longleftrightarrow> x=0"
   by (auto simp: ZFC_in_HOL.ext)
 
 instantiation V :: distrib_lattice
 begin
 
 definition inf_V where "inf_V x y \<equiv> set (elts x \<inter> elts y)"
 
 definition sup_V where "sup_V x y \<equiv> set (elts x \<union> elts y)"
 
 definition less_eq_V where "less_eq_V x y \<equiv> elts x \<subseteq> elts y"
 
 definition less_V where "less_V x y \<equiv> less_eq x y \<and> x \<noteq> (y::V)"
 
 instance
 proof
   show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" for x :: V and y :: V
     using ext less_V_def less_eq_V_def by auto
   show "x \<le> x" for x :: V
     by (simp add: less_eq_V_def)
   show "x \<le> z" if "x \<le> y" "y \<le> z" for x y z :: V
     using that by (auto simp: less_eq_V_def)
   show "x = y" if "x \<le> y" "y \<le> x" for x y :: V
     using that by (simp add: ext less_eq_V_def)
   show "inf x y \<le> x" for x y :: V
     by (metis down elts_of_set inf_V_def inf_sup_ord(1) less_eq_V_def)
   show "inf x y \<le> y" for x y :: V
     by (metis Int_lower2 down elts_of_set inf_V_def less_eq_V_def)
   show "x \<le> inf y z" if "x \<le> y" "x \<le> z" for x y z :: V
   proof -
     have "small (elts y \<inter> elts z)"
       by (meson down inf.cobounded1)
     then show ?thesis
       using elts_of_set inf_V_def less_eq_V_def that by auto
   qed
   show "x \<le> x \<squnion> y" "y \<le> x \<squnion> y" for x y :: V
     by (simp_all add: less_eq_V_def small_Un_elts sup_V_def)
   show "sup y z \<le> x" if "y \<le> x" "z \<le> x" for x y z :: V
     using less_eq_V_def sup_V_def that by auto
   show "sup x (inf y z) = inf (x \<squnion> y) (sup x z)" for x y z :: V
   proof -
     have "small (elts y \<inter> elts z)"
       by (meson down inf.cobounded2)
     then show ?thesis
       by (simp add: Un_Int_distrib inf_V_def small_Un_elts sup_V_def)
   qed
 qed
 end
 
 lemma V_equalityI [intro]: "(\<And>x. x \<in> elts a \<longleftrightarrow> x \<in> elts b) \<Longrightarrow> a = b"
   by (meson dual_order.antisym less_eq_V_def subsetI)
 
 lemma vsubsetI [intro!]: "(\<And>x. x \<in> elts a \<Longrightarrow> x \<in> elts b) \<Longrightarrow> a \<le> b"
   by (simp add: less_eq_V_def subsetI)
 
 lemma vsubsetD [elim, intro?]: "a \<le> b \<Longrightarrow> c \<in> elts a \<Longrightarrow> c \<in> elts b"
   using less_eq_V_def by auto
 
 lemma rev_vsubsetD: "c \<in> elts a \<Longrightarrow> a \<le> b \<Longrightarrow> c \<in> elts b"
   \<comment> \<open>The same, with reversed premises for use with @{method erule} -- cf. @{thm rev_mp}.\<close>
   by (rule vsubsetD)
 
 lemma vsubsetCE [elim,no_atp]: "a \<le> b \<Longrightarrow> (c \<notin> elts a \<Longrightarrow> P) \<Longrightarrow> (c \<in> elts b \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>Classical elimination rule.\<close>
   using vsubsetD by blast
 
 lemma set_image_le_iff: "small A \<Longrightarrow> set (f ` A) \<le> B \<longleftrightarrow> (\<forall>x\<in>A. f x \<in> elts B)"
   by auto
 
 lemma eq0_iff: "x = 0 \<longleftrightarrow> (\<forall>y. y \<notin> elts x)"
   by auto
 
 lemma less_eq_V_0_iff [simp]: "x \<le> 0 \<longleftrightarrow> x = 0" for x::V
   by auto
 
 lemma subset_iff_less_eq_V:
   assumes "small B" shows "A \<subseteq> B \<longleftrightarrow> set A \<le> set B \<and> small A"
   using assms down small_iff by auto
 
 lemma small_Collect [simp]: "small A \<Longrightarrow> small {x \<in> A. P x}"
   by (simp add: smaller_than_small)
 
 lemma small_Union_iff: "small (\<Union>(elts ` X)) \<longleftrightarrow> small X"
   proof
   show "small X"
     if "small (\<Union> (elts ` X))"
   proof -
     have "X \<subseteq> set ` Pow (\<Union> (elts ` X))"
       by fastforce
     then show ?thesis
       using Pow subset_iff_less_eq_V that by auto
   qed
 qed auto
 
 lemma not_less_0 [iff]:
   fixes x::V shows "\<not> x < 0"
   by (simp add: less_eq_V_def less_le_not_le)
 
 lemma le_0 [iff]:
   fixes x::V shows "0 \<le> x"
   by auto
 
 lemma min_0L [simp]: "min 0 n = 0" for n :: V
   by (simp add: min_absorb1)
 
 lemma min_0R [simp]: "min n 0 = 0" for n :: V
   by (simp add: min_absorb2)
 
 lemma neq0_conv: "\<And>n::V. n \<noteq> 0 \<longleftrightarrow> 0 < n"
   by (simp add: less_V_def)
 
 
 definition VPow :: "V \<Rightarrow> V"
   where "VPow x \<equiv> set (set ` Pow (elts x))"
 
 lemma VPow_iff [iff]: "y \<in> elts (VPow x) \<longleftrightarrow> y \<le> x"
   using down Pow
   apply (auto simp: VPow_def less_eq_V_def)
   using less_eq_V_def apply fastforce
   done
 
 lemma VPow_le_VPow_iff [simp]: "VPow a \<le> VPow b \<longleftrightarrow> a \<le> b"
   by auto
 
 lemma elts_VPow: "elts (VPow x) = set ` Pow (elts x)"
   by (auto simp: VPow_def Pow)
 
 lemma small_sup_iff [simp]: "small (X \<union> Y) \<longleftrightarrow> small X \<and> small Y" for X::"V set"
   by (metis down elts_of_set small_Un_elts sup_ge1 sup_ge2)
 
 lemma elts_sup_iff [simp]: "elts (x \<squnion> y) = elts x \<union> elts y"
   by (simp add: sup_V_def)
 
 lemma trad_foundation:
   assumes z: "z \<noteq> 0" shows "\<exists>w. w \<in> elts z \<and> w \<sqinter> z = 0"
   using foundation assms
   by (simp add: wf_eq_minimal) (metis Int_emptyI equals0I inf_V_def set_of_elts zero_V_def)
 
 
 instantiation "V" :: Sup
 begin
 definition Sup_V where "Sup_V X \<equiv> if small X then set (Union (elts ` X)) else 0"
 instance ..
 end
 
 instantiation "V" :: Inf
 begin
 definition Inf_V where "Inf_V X \<equiv> if X = {} then 0 else set (Inter (elts ` X))"
 instance ..
 end
 
 lemma V_disjoint_iff: "x \<sqinter> y = 0 \<longleftrightarrow> elts x \<inter> elts y = {}"
   by (metis down elts_of_set inf_V_def inf_le1 zero_V_def)
 
 text\<open>I've no idea why @{term bdd_above} is treated differently from @{term bdd_below}, but anyway\<close>
 lemma bdd_above_iff_small [simp]: "bdd_above X = small X" for X::"V set"
 proof
   show "small X" if "bdd_above X"
   proof -
     obtain a where "\<forall>x\<in>X. x \<le> a"
       using that \<open>bdd_above X\<close> bdd_above_def by blast
     then show "small X"
       by (meson VPow_iff \<open>\<forall>x\<in>X. x \<le> a\<close> down subsetI)
   qed
   show "bdd_above X"
     if "small X"
   proof -
     have "\<forall>x\<in>X. x \<le> \<Squnion> X"
       by (simp add: SUP_upper Sup_V_def Union less_eq_V_def that)
     then show ?thesis
       by (meson bdd_above_def)
   qed
 qed
 
 
 instantiation "V" :: conditionally_complete_lattice
 begin
 
 definition bdd_below_V where "bdd_below_V X \<equiv> X \<noteq> {}"
 
 instance
   proof
   show "\<Sqinter> X \<le> x" if "x \<in> X" "bdd_below X"
     for x :: V and X :: "V set"
     using that by (auto simp: bdd_below_V_def Inf_V_def split: if_split_asm)
   show "z \<le> \<Sqinter> X"
     if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
     for X :: "V set" and z :: V
     using that
     apply (clarsimp simp add: bdd_below_V_def Inf_V_def less_eq_V_def split: if_split_asm)
     by (meson INT_subset_iff down eq_refl equals0I)
   show "x \<le> \<Squnion> X" if "x \<in> X" and "bdd_above X" for x :: V and X :: "V set"
     using that Sup_V_def by auto
   show "\<Squnion> X \<le> (z::V)" if "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> x \<le> z" for X :: "V set" and z :: V
     using that  by (simp add: SUP_least Sup_V_def less_eq_V_def)
 qed
 end
 
 lemma Sup_upper: "\<lbrakk>x \<in> A; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>A" for A::"V set"
   by (auto simp: Sup_V_def SUP_upper Union less_eq_V_def)
 
 lemma Sup_least:
   fixes z::V shows "(\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>A \<le> z"
   by (auto simp: Sup_V_def SUP_least less_eq_V_def)
 
 lemma Sup_empty [simp]: "\<Squnion>{} = (0::V)"
   using Sup_V_def by auto
 
 lemma elts_Sup [simp]: "small X \<Longrightarrow> elts (\<Squnion> X) = \<Union>(elts ` X)"
   by (auto simp: Sup_V_def)
 
 lemma sup_V_0_left [simp]: "0 \<squnion> a = a" and sup_V_0_right [simp]: "a \<squnion> 0 = a" for a::V
   by auto
 
 lemma Sup_V_insert:
   fixes x::V assumes "small A" shows "\<Squnion>(insert x A) = x \<squnion> \<Squnion>A"
   by (simp add: assms cSup_insert_If)
 
 lemma Sup_Un_distrib: "\<lbrakk>small A; small B\<rbrakk> \<Longrightarrow> \<Squnion>(A \<union> B) = \<Squnion>A \<squnion> \<Squnion>B" for A::"V set"
   by auto
 
 lemma SUP_sup_distrib:
   fixes f :: "V \<Rightarrow> V"
-  shows "small A \<Longrightarrow> (SUP x\<in>A. f x \<squnion> g x) = \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A)"
+  shows "small A \<Longrightarrow> (\<Squnion>x\<in>A. f x \<squnion> g x) = \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A)"
   by (force simp:)
 
-lemma SUP_const [simp]: "(SUP y \<in> A. a) = (if A = {} then (0::V) else a)"
+lemma SUP_const [simp]: "(\<Squnion>y \<in> A. a) = (if A = {} then (0::V) else a)"
   by simp
 
 lemma cSUP_subset_mono:
   fixes f :: "'a \<Rightarrow> V set" and g :: "'a \<Rightarrow> V set"
   shows "\<lbrakk>A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
   by (simp add: SUP_subset_mono)
 
 lemma mem_Sup_iff [iff]: "x \<in> elts (\<Squnion>X) \<longleftrightarrow> x \<in> \<Union> (elts ` X) \<and> small X"
   using Sup_V_def by auto
 
 lemma cSUP_UNION:
   fixes B :: "V \<Rightarrow> V set" and f :: "V \<Rightarrow> V"
   assumes ne: "small A" and bdd_UN: "small (\<Union>x\<in>A. f ` B x)"
   shows "\<Squnion>(f ` (\<Union>x\<in>A. B x)) = \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
 proof -
   have bdd: "\<And>x. x \<in> A \<Longrightarrow> small (f ` B x)"
     using bdd_UN subset_iff_less_eq_V
     by (meson SUP_upper smaller_than_small)
   then have bdd2: "small ((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
     using ne(1) by blast
   have "\<Squnion>(f ` (\<Union>x\<in>A. B x)) \<le> \<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A)"
     using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
   moreover have "\<Squnion>((\<lambda>x. \<Squnion>(f ` B x)) ` A) \<le> \<Squnion>(f ` (\<Union>x\<in>A. B x))"
     using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
   ultimately show ?thesis
     by (rule order_antisym)
 qed
 
 lemma Sup_subset_mono: "small B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B" for A::"V set"
   by auto
 
 lemma Sup_le_iff: "small A \<Longrightarrow> Sup A \<le> a \<longleftrightarrow> (\<forall>x\<in>A. x \<le> a)" for A::"V set"
   by auto
 
 lemma SUP_le_iff: "small (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)" for f :: "V \<Rightarrow> V"
   by blast
 
 lemma Sup_eq_0_iff [simp]: "\<Squnion>A = 0 \<longleftrightarrow> A \<subseteq> {0} \<or> \<not> small A" for A :: "V set"
   using Sup_upper by fastforce
 
 lemma Sup_Union_commute:
   fixes f :: "V \<Rightarrow> V set"
   assumes "small A" "\<And>x. x\<in>A \<Longrightarrow> small (f x)"
-  shows "\<Squnion> (\<Union>x\<in>A. f x) = (SUP x\<in>A. \<Squnion> (f x))"
+  shows "\<Squnion> (\<Union>x\<in>A. f x) = (\<Squnion>x\<in>A. \<Squnion> (f x))"
   using assms 
   by (force simp: subset_iff_less_eq_V intro!: antisym)
 
 lemma Sup_eq_Sup:
   fixes B :: "V set"
   assumes "B \<subseteq> A" "small A" and *: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y \<in> B. x \<le> y"
   shows "Sup A = Sup B"
 proof -
   have "small B"
     using assms subset_iff_less_eq_V by auto
   moreover have "\<exists>y\<in>B. u \<in> elts y"
     if "x \<in> A" "u \<in> elts x" for u x
     using that "*" by blast
   moreover have "\<exists>x\<in>A. v \<in> elts x"
     if "y \<in> B" "v \<in> elts y" for v y
     using that \<open>B \<subseteq> A\<close> by blast
   ultimately show ?thesis
     using assms by auto
 qed
 
 subsection\<open>Successor function\<close>
 
 lemma vinsert_not_empty [simp]: "vinsert a A \<noteq> 0"
   and empty_not_vinsert [simp]: "0 \<noteq> vinsert a A"
   by (auto simp: vinsert_def)
 
 lemma succ_not_0 [simp]: "succ n \<noteq> 0" and zero_not_succ [simp]: "0 \<noteq> succ n"
   by (auto simp: succ_def)
 
 instantiation V :: zero_neq_one
 begin
 instance 
   by intro_classes (metis elts_0 elts_succ empty_iff insert_iff one_V_def set_of_elts)
 end
 
 instantiation V :: zero_less_one
 begin
 instance 
   by intro_classes (simp add: less_V_def)
 end
 
 lemma succ_ne_self [simp]: "i \<noteq> succ i"
   by (metis elts_succ insertI1 mem_not_refl)
 
 lemma succ_notin_self: "succ i \<notin> elts i"
   using elts_succ mem_not_refl by blast
 
 lemma le_succE: "succ i \<le> succ j \<Longrightarrow> i \<le> j"
   using less_eq_V_def mem_not_sym by auto
 
 lemma succ_inject_iff [iff]: "succ i = succ j \<longleftrightarrow> i = j"
   by (simp add: dual_order.antisym le_succE)
 
 lemma inj_succ: "inj succ"
   by (simp add: inj_def)
 
 lemma succ_neq_zero: "succ x \<noteq> 0"
   by (metis elts_0 elts_succ insert_not_empty)
 
 definition pred where "pred i \<equiv> THE j. i = succ j"
 
 lemma pred_succ [simp]: "pred (succ i) = i"
   by (simp add: pred_def)
 
 
 subsection \<open>Ordinals\<close>
 
 definition Transset where "Transset x \<equiv> \<forall>y \<in> elts x. y \<le> x"
 
 definition Ord where "Ord x \<equiv> Transset x \<and> (\<forall>y \<in> elts x. Transset y)"
 
 abbreviation ON where "ON \<equiv> Collect Ord"
 
 subsubsection \<open>Transitive sets\<close>
 
 lemma Transset_0 [iff]: "Transset 0"
   by (auto simp: Transset_def)
 
 lemma Transset_succ [intro]:
   assumes "Transset x" shows "Transset (succ x)"
   using assms
   by (auto simp: Transset_def succ_def less_eq_V_def)
 
 lemma Transset_Sup:
   assumes "\<And>x. x \<in> X \<Longrightarrow> Transset x" shows "Transset (\<Squnion>X)"
 proof (cases "small X")
   case True
   with assms show ?thesis
     by (simp add: Transset_def) (meson Sup_upper assms dual_order.trans)
 qed (simp add: Sup_V_def)
 
 lemma Transset_sup:
   assumes "Transset x" "Transset y" shows "Transset (x \<squnion> y)"
   using Transset_def assms by fastforce
 
 lemma Transset_inf: "\<lbrakk>Transset i; Transset j\<rbrakk> \<Longrightarrow> Transset (i \<sqinter> j)"
   by (simp add: Transset_def rev_vsubsetD)
 
 lemma Transset_VPow: "Transset(i) \<Longrightarrow> Transset(VPow(i))"
   by (auto simp: Transset_def)
 
 lemma Transset_Inf: "(\<And>i. i \<in> A \<Longrightarrow> Transset i) \<Longrightarrow> Transset (\<Sqinter> A)"
   by (force simp: Transset_def Inf_V_def)
 
 lemma Transset_SUP: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Squnion> (B ` A))"
   by (metis Transset_Sup imageE)
 
 lemma Transset_INT: "(\<And>x. x \<in> A \<Longrightarrow> Transset (B x)) \<Longrightarrow> Transset (\<Sqinter> (B ` A))"
   by (metis Transset_Inf imageE)
 
 
 subsubsection \<open>Zero, successor, sups\<close>
 
 lemma Ord_0 [iff]: "Ord 0"
   by (auto simp: Ord_def)
 
 lemma Ord_succ [intro]:
   assumes "Ord x" shows "Ord (succ x)"
   using assms by (auto simp: Ord_def)
 
 lemma Ord_Sup:
   assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" shows "Ord (\<Squnion>X)"
 proof (cases "small X")
   case True
   with assms show ?thesis
     by (auto simp: Ord_def Transset_Sup)
 qed (simp add: Sup_V_def)
 
 lemma Ord_Union:
   assumes "\<And>x. x \<in> X \<Longrightarrow> Ord x" "small X" shows "Ord (set (\<Union> (elts ` X)))"
   by (metis Ord_Sup Sup_V_def assms)
 
 lemma Ord_sup:
   assumes "Ord x" "Ord y" shows "Ord (x \<squnion> y)"
   using assms
   proof (clarsimp simp: Ord_def)
   show "Transset (x \<squnion> y) \<and> (\<forall>y\<in>elts x \<union> elts y. Transset y)"
     if "Transset x" "Transset y" "\<forall>y\<in>elts x. Transset y" "\<forall>y\<in>elts y. Transset y"
     using Ord_def Transset_sup assms by auto
 qed
 
 lemma big_ON [simp]: "\<not> small ON"
 proof
   assume "small ON"
   then have "set ON \<in> ON"
     by (metis Ord_Union Ord_succ Sup_upper elts_Sup elts_succ insertI1 mem_Collect_eq mem_not_refl set_of_elts vsubsetD)
   then show False
     by (metis \<open>small ON\<close> elts_of_set mem_not_refl)
 qed
 
 lemma Ord_1 [iff]: "Ord 1"
   using Ord_succ one_V_def succ_def vinsert_def by fastforce
 
 lemma OrdmemD: "Ord k \<Longrightarrow> j \<in> elts k \<Longrightarrow> j < k"
   using Ord_def Transset_def less_V_def by auto
 
 lemma Ord_trans: "\<lbrakk> i \<in> elts j;  j \<in> elts k;  Ord k \<rbrakk>  \<Longrightarrow> i \<in> elts k"
   using Ord_def Transset_def by blast
 
 lemma mem_0_Ord:
   assumes k: "Ord k" and knz: "k \<noteq> 0" shows "0 \<in> elts k"
   by (metis Ord_def Transset_def inf.orderE k knz trad_foundation)
 
 lemma Ord_in_Ord: "\<lbrakk> Ord k;  m \<in> elts k \<rbrakk>  \<Longrightarrow> Ord m"
   using Ord_def Ord_trans by blast
 
 lemma OrdI: "\<lbrakk>Transset i; \<And>x. x \<in> elts i \<Longrightarrow> Transset x\<rbrakk> \<Longrightarrow> Ord i"
   by (simp add: Ord_def)
 
 lemma Ord_is_Transset: "Ord i \<Longrightarrow> Transset i"
   by (simp add: Ord_def)
 
 lemma Ord_contains_Transset: "\<lbrakk>Ord i; j \<in> elts i\<rbrakk> \<Longrightarrow> Transset j"
   using Ord_def by blast
 
 lemma ON_imp_Ord:
   assumes "H \<subseteq> ON" "x \<in> H"
   shows "Ord x"
   using assms by blast
 
 lemma elts_subset_ON: "Ord \<alpha> \<Longrightarrow> elts \<alpha> \<subseteq> ON"
   using Ord_in_Ord by blast
 
 lemma Transset_pred [simp]: "Transset x \<Longrightarrow> \<Squnion>(elts (succ x)) = x"
   by (fastforce simp: Transset_def)
 
 lemma Ord_pred [simp]: "Ord \<beta> \<Longrightarrow> \<Squnion> (insert \<beta> (elts \<beta>)) = \<beta>"
   using Ord_def Transset_pred by auto
 
 
 subsubsection \<open>Induction, Linearity, etc.\<close>
 
 lemma Ord_induct [consumes 1, case_names step]:
   assumes k: "Ord k"
       and step: "\<And>x.\<lbrakk> Ord x; \<And>y. y \<in> elts x \<Longrightarrow> P y \<rbrakk>  \<Longrightarrow> P x"
     shows "P k"
   using foundation k
 proof (induction k rule: wf_induct_rule)
   case (less x)
   then show ?case
     using Ord_in_Ord local.step by auto
 qed
 
 text \<open>Comparability of ordinals\<close>
 lemma Ord_linear: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<or> k=l \<or> l \<in> elts k"
 proof (induct k arbitrary: l rule: Ord_induct)
   case (step k)
   note step_k = step
   show ?case using \<open>Ord l\<close>
     proof (induct l rule: Ord_induct)
       case (step l)
       thus ?case using step_k
         by (metis Ord_trans V_equalityI)
     qed
 qed
 
 text \<open>The trichotomy law for ordinals\<close>
 lemma Ord_linear_lt:
   assumes "Ord k" "Ord l"
   obtains (lt) "k < l" | (eq) "k=l" | (gt) "l < k"
   using Ord_linear OrdmemD assms by blast
 
 lemma Ord_linear2:
   assumes "Ord k" "Ord l"
   obtains (lt) "k < l" | (ge) "l \<le> k"
   by (metis Ord_linear_lt eq_refl assms order.strict_implies_order)
 
 lemma Ord_linear_le:
   assumes "Ord k" "Ord l"
   obtains (le) "k \<le> l" | (ge) "l \<le> k"
   by (meson Ord_linear2 le_less assms)
 
 lemma union_less_iff [simp]: "\<lbrakk>Ord i; Ord j\<rbrakk> \<Longrightarrow> i \<squnion> j < k \<longleftrightarrow> i<k \<and> j<k"
   by (metis Ord_linear_le le_iff_sup sup.order_iff sup.strict_boundedE)
 
 lemma Ord_mem_iff_lt: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k \<in> elts l \<longleftrightarrow> k < l"
   by (metis Ord_linear OrdmemD less_le_not_le)
 
 lemma Ord_Collect_lt: "Ord \<alpha> \<Longrightarrow> {\<xi>. Ord \<xi> \<and> \<xi> < \<alpha>} = elts \<alpha>"
   by (auto simp flip: Ord_mem_iff_lt elim: Ord_in_Ord OrdmemD)
 
 lemma Ord_not_less: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x < y \<longleftrightarrow> y \<le> x"
   by (metis (no_types) Ord_linear2 leD)
 
 lemma Ord_not_le: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> \<not> x \<le> y \<longleftrightarrow> y < x"
   by (metis (no_types) Ord_linear2 leD)
 
 lemma le_succ_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> succ j \<longleftrightarrow> i \<le> j"
   by (metis Ord_linear_le Ord_succ le_succE order_antisym)
 
 lemma succ_le_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> j \<longleftrightarrow> i < j"
   using Ord_mem_iff_lt dual_order.strict_implies_order less_eq_V_def by fastforce
 
 lemma succ_in_Sup_Ord:
   assumes eq: "succ \<beta> = \<Squnion>A" and "small A" "A \<subseteq> ON" "Ord \<beta>"
   shows "succ \<beta> \<in> A"
 proof -
   have "\<not> \<Squnion>A \<le> \<beta>"
     using eq \<open>Ord \<beta>\<close> succ_le_iff by fastforce
   then show ?thesis
     using assms by (metis Ord_linear2 Sup_least Sup_upper eq_iff mem_Collect_eq subsetD succ_le_iff)
 qed
 
 lemma in_succ_iff: "Ord i \<Longrightarrow> j \<in> elts (ZFC_in_HOL.succ i) \<longleftrightarrow> Ord j \<and> j \<le> i"
   by (metis Ord_in_Ord Ord_mem_iff_lt Ord_not_le Ord_succ succ_le_iff)
 
 lemma zero_in_succ [simp,intro]: "Ord i \<Longrightarrow> 0 \<in> elts (succ i)"
   using mem_0_Ord by auto
 
 lemma Ord_finite_Sup: "\<lbrakk>finite A; A \<subseteq> ON; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<Squnion>A \<in> A"
 proof (induction A rule: finite_induct)
   case (insert x A)
   then have *: "small A" "A \<subseteq> ON" "Ord x"
     by (auto simp add: ZFC_in_HOL.finite_imp_small insert.hyps)
   show ?case
   proof (cases "A = {}")
     case False
     then have "\<Squnion>A \<in> A"
       using insert by blast
     then have "\<Squnion>A \<le> x" if "x \<squnion> \<Squnion>A \<notin> A"
       using * by (metis ON_imp_Ord Ord_linear_le sup.absorb2 that)
     then show ?thesis
       by (fastforce simp: \<open>small A\<close> Sup_V_insert)
   qed auto
 qed auto
 
 
 subsubsection \<open>The natural numbers\<close>
 
 primrec ord_of_nat :: "nat \<Rightarrow> V" where
   "ord_of_nat 0 = 0"
 | "ord_of_nat (Suc n) = succ (ord_of_nat n)"
 
 lemma ord_of_nat_eq_initial: "ord_of_nat n = set (ord_of_nat ` {..<n})"
   by (induction n) (auto simp: lessThan_Suc succ_def)
 
 lemma mem_ord_of_nat_iff [simp]: "x \<in> elts (ord_of_nat n) \<longleftrightarrow> (\<exists>m<n. x = ord_of_nat m)"
   by (subst ord_of_nat_eq_initial) auto
 
 lemma elts_ord_of_nat: "elts (ord_of_nat k) = ord_of_nat ` {..<k}"
   by auto
 
 lemma Ord_equality: "Ord i \<Longrightarrow> i = \<Squnion> (succ ` elts i)"
   by (force intro: Ord_trans)
 
 lemma Ord_ord_of_nat [simp]: "Ord (ord_of_nat k)"
   by (induct k, auto)
 
 lemma ord_of_nat_equality: "ord_of_nat n = \<Squnion> ((succ \<circ> ord_of_nat) ` {..<n})"
   by (metis Ord_equality Ord_ord_of_nat elts_of_set image_comp small_image_nat_V ord_of_nat_eq_initial)
 
 definition \<omega> :: V where "\<omega> \<equiv> set (range ord_of_nat)"
 
 lemma elts_\<omega>: "elts \<omega> = {\<alpha>. \<exists>n. \<alpha> = ord_of_nat n}"
   by (auto simp: \<omega>_def image_iff)
 
 lemma nat_into_Ord [simp]: "n \<in> elts \<omega> \<Longrightarrow> Ord n"
   by (metis Ord_ord_of_nat \<omega>_def elts_of_set image_iff inf)
 
 lemma Sup_\<omega>: "\<Squnion>(elts \<omega>) = \<omega>"
   unfolding \<omega>_def by force
 
 lemma Ord_\<omega> [iff]: "Ord \<omega>"
   by (metis Ord_Sup Sup_\<omega> nat_into_Ord)
 
 lemma zero_in_omega [iff]: "0 \<in> elts \<omega>"
   by (metis \<omega>_def elts_of_set inf ord_of_nat.simps(1) rangeI)
 
 lemma succ_in_omega [simp]: "n \<in> elts \<omega> \<Longrightarrow> succ n \<in> elts \<omega>"
   by (metis \<omega>_def elts_of_set image_iff small_image_nat_V ord_of_nat.simps(2) rangeI)
 
 lemma ord_of_eq_0: "ord_of_nat j = 0 \<Longrightarrow> j = 0"
   by (induct j) (auto simp: succ_neq_zero)
 
 lemma ord_of_nat_le_omega: "ord_of_nat n \<le> \<omega>"
   by (metis Sup_\<omega> ZFC_in_HOL.Sup_upper \<omega>_def elts_of_set inf rangeI)
 
 lemma ord_of_eq_0_iff [simp]: "ord_of_nat n = 0 \<longleftrightarrow> n=0"
   by (auto simp: ord_of_eq_0)
 
 lemma ord_of_nat_inject [iff]: "ord_of_nat i = ord_of_nat j \<longleftrightarrow> i=j"
 proof (induct i arbitrary: j)
   case 0 show ?case
     using ord_of_eq_0 by auto
 next
   case (Suc i) then show ?case
     by auto (metis elts_0 elts_succ insert_not_empty not0_implies_Suc ord_of_nat.simps succ_inject_iff)
 qed
 
 corollary inj_ord_of_nat: "inj ord_of_nat"
   by (simp add: linorder_injI)
 
 corollary countable:
   assumes "countable X" shows "small X"
 proof -
   have "X \<subseteq> range (from_nat_into X)"
     by (simp add: assms subset_range_from_nat_into)
   then show ?thesis
     by (meson inf_raw inj_ord_of_nat replacement small_def smaller_than_small)
 qed
 
 corollary infinite_\<omega>: "infinite (elts \<omega>)"
   using range_inj_infinite [of ord_of_nat]
   by (simp add: \<omega>_def inj_ord_of_nat)
 
 corollary ord_of_nat_mono_iff [iff]: "ord_of_nat i \<le> ord_of_nat j \<longleftrightarrow> i \<le> j"
   by (metis Ord_def Ord_ord_of_nat Transset_def eq_iff mem_ord_of_nat_iff not_less ord_of_nat_inject)
 
 corollary ord_of_nat_strict_mono_iff [iff]: "ord_of_nat i < ord_of_nat j \<longleftrightarrow> i < j"
   by (simp add: less_le_not_le)
 
 lemma small_image_nat [simp]:
   fixes N :: "nat set" shows "small (g ` N)"
   by (simp add: countable)
 
 lemma finite_Ord_omega: "\<alpha> \<in> elts \<omega> \<Longrightarrow> finite (elts \<alpha>)"
   proof (clarsimp simp add: \<omega>_def)
   show "finite (elts (ord_of_nat n))" if "\<alpha> = ord_of_nat n" for n
     using that by (simp add: ord_of_nat_eq_initial [of n])
 qed
 
 lemma infinite_Ord_omega: "Ord \<alpha> \<Longrightarrow> infinite (elts \<alpha>) \<Longrightarrow> \<omega> \<le> \<alpha>"
   by (meson Ord_\<omega> Ord_linear2 Ord_mem_iff_lt finite_Ord_omega)
 
 lemma ord_of_minus_1: "n > 0 \<Longrightarrow> ord_of_nat n = succ (ord_of_nat (n - 1))"
   by (metis Suc_diff_1 ord_of_nat.simps(2))
 
 lemma card_ord_of_nat [simp]: "card (elts (ord_of_nat m)) = m"
   by (induction m) (auto simp: \<omega>_def finite_Ord_omega)
 
 lemma ord_of_nat_\<omega> [iff]:"ord_of_nat n \<in> elts \<omega>"
   by (simp add: \<omega>_def)
 
 lemma succ_\<omega>_iff [iff]: "succ n \<in> elts \<omega> \<longleftrightarrow> n \<in> elts \<omega>"
   by (metis Ord_\<omega> OrdmemD elts_vinsert insert_iff less_V_def succ_def succ_in_omega vsubsetD)
 
 lemma \<omega>_gt0 [simp]: "\<omega> > 0"
   by (simp add: OrdmemD)
 
 lemma \<omega>_gt1 [simp]: "\<omega> > 1"
   by (simp add: OrdmemD one_V_def)
 
 subsubsection\<open>Limit ordinals\<close>
 
 definition Limit :: "V\<Rightarrow>bool"
   where "Limit i \<equiv> Ord i \<and> 0 \<in> elts i \<and> (\<forall>y. y \<in> elts i \<longrightarrow> succ y \<in> elts i)"
 
 lemma zero_not_Limit [iff]: "\<not> Limit 0"
   by (simp add: Limit_def)
 
 lemma not_succ_Limit [simp]: "\<not> Limit(succ i)"
   by (metis Limit_def Ord_mem_iff_lt elts_succ insertI1 less_irrefl)
 
 lemma Limit_is_Ord: "Limit \<xi> \<Longrightarrow> Ord \<xi>"
   by (simp add: Limit_def)
 
 lemma succ_in_Limit_iff: "Limit \<xi> \<Longrightarrow> succ \<alpha> \<in> elts \<xi> \<longleftrightarrow> \<alpha> \<in> elts \<xi>"
   by (metis Limit_def OrdmemD elts_succ insertI1 less_V_def vsubsetD)
 
 lemma Limit_eq_Sup_self [simp]: "Limit i \<Longrightarrow> Sup (elts i) = i"
   apply (rule order_antisym)
   apply (simp add: Limit_def Ord_def Transset_def Sup_least)
   by (metis Limit_def Ord_equality Sup_V_def SUP_le_iff Sup_upper small_elts)
 
 lemma zero_less_Limit: "Limit \<beta> \<Longrightarrow> 0 < \<beta>"
   by (simp add: Limit_def OrdmemD)
 
 lemma non_Limit_ord_of_nat [iff]: "\<not> Limit (ord_of_nat m)"
   by (metis Limit_def mem_ord_of_nat_iff not_succ_Limit ord_of_eq_0_iff ord_of_minus_1)
 
 lemma Limit_omega [iff]: "Limit \<omega>"
   by (simp add: Limit_def)
 
 lemma omega_nonzero [simp]: "\<omega> \<noteq> 0"
   using Limit_omega by fastforce
 
 lemma Ord_cases_lemma:
   assumes "Ord k" shows "k = 0 \<or> (\<exists>j. k = succ j) \<or> Limit k"
 proof (cases "Limit k")
   case False
   have "succ j \<in> elts k" if  "\<forall>j. k \<noteq> succ j" "j \<in> elts k" for j
     by (metis Ord_in_Ord Ord_linear Ord_succ assms elts_succ insertE mem_not_sym that)
   with assms show ?thesis
     by (auto simp: Limit_def mem_0_Ord)
 qed auto
 
 lemma Ord_cases [cases type: V, case_names 0 succ limit]:
   assumes "Ord k"
   obtains "k = 0" | l where "Ord l" "succ l = k" | "Limit k"
   by (metis assms Ord_cases_lemma Ord_in_Ord elts_succ insertI1)
 
 lemma non_succ_LimitI:
   assumes "i\<noteq>0" "Ord(i)" "\<And>y. succ(y) \<noteq> i"
   shows "Limit(i)"
   using Ord_cases_lemma assms by blast
 
 lemma Ord_induct3 [consumes 1, case_names 0 succ Limit, induct type: V]:
   assumes \<alpha>: "Ord \<alpha>"
     and P: "P 0" "\<And>\<alpha>. \<lbrakk>Ord \<alpha>; P \<alpha>\<rbrakk> \<Longrightarrow> P (succ \<alpha>)"
-           "\<And>\<alpha>. \<lbrakk>Limit \<alpha>; \<And>\<xi>. \<xi> \<in> elts \<alpha> \<Longrightarrow> P \<xi>\<rbrakk> \<Longrightarrow> P (SUP \<xi> \<in> elts \<alpha>. \<xi>)"
+           "\<And>\<alpha>. \<lbrakk>Limit \<alpha>; \<And>\<xi>. \<xi> \<in> elts \<alpha> \<Longrightarrow> P \<xi>\<rbrakk> \<Longrightarrow> P (\<Squnion>\<xi> \<in> elts \<alpha>. \<xi>)"
   shows "P \<alpha>"
   using \<alpha>
 proof (induction \<alpha> rule: Ord_induct)
   case (step \<alpha>)
   then show ?case
     by (metis Limit_eq_Sup_self Ord_cases P elts_succ image_ident insertI1)
 qed
 
 
 subsubsection\<open>Properties of LEAST for ordinals\<close>
 
 lemma
   assumes "Ord k" "P k"
   shows Ord_LeastI: "P (LEAST i. Ord i \<and> P i)" and Ord_Least_le: "(LEAST i. Ord i \<and> P i) \<le> k"
 proof -
   have "P (LEAST i. Ord i \<and> P i) \<and> (LEAST i. Ord i \<and> P i) \<le> k"
     using assms
   proof (induct k rule: Ord_induct)
     case (step x) then have "P x" by simp
     show ?case proof (rule classical)
       assume assm: "\<not> (P (LEAST a. Ord a \<and> P a) \<and> (LEAST a. Ord a \<and> P a) \<le> x)"
       have "\<And>y. Ord y \<and> P y \<Longrightarrow> x \<le> y"
       proof (rule classical)
         fix y
         assume y: "Ord y \<and> P y" "\<not> x \<le> y"
         with step obtain "P (LEAST a. Ord a \<and> P a)" and le: "(LEAST a. Ord a \<and> P a) \<le> y"
           by (meson Ord_linear2 Ord_mem_iff_lt)
         with assm have "x < (LEAST a. Ord a \<and> P a)"
           by (meson Ord_linear_le y order.trans \<open>Ord x\<close>)
         then show "x \<le> y"
           using le by auto
       qed
       then have Least: "(LEAST a. Ord a \<and> P a) = x"
         by (simp add: Least_equality \<open>Ord x\<close> step.prems)
       with \<open>P x\<close> show ?thesis by simp
     qed
   qed
   then show "P (LEAST i. Ord i \<and> P i)" and "(LEAST i. Ord i \<and> P i) \<le> k" by auto
 qed
 
 lemma Ord_Least:
   assumes "Ord k" "P k"
   shows "Ord (LEAST i. Ord i \<and> P i)"
 proof -
   have "Ord (LEAST i. Ord i \<and> (Ord i \<and> P i))"
     using Ord_LeastI [where P = "\<lambda>i. Ord i \<and> P i"] assms by blast
   then show ?thesis
     by simp
 qed
 
 \<comment> \<open>The following 3 lemmas are due to Brian Huffman\<close>
 lemma Ord_LeastI_ex: "\<exists>i. Ord i \<and> P i \<Longrightarrow> P (LEAST i. Ord i \<and> P i)"
   using Ord_LeastI by blast
 
 lemma Ord_LeastI2:
   "\<lbrakk>Ord a; P a; \<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
   by (blast intro: Ord_LeastI Ord_Least)
 
 lemma Ord_LeastI2_ex:
   "\<exists>a. Ord a \<and> P a \<Longrightarrow> (\<And>x. \<lbrakk>Ord x; P x\<rbrakk> \<Longrightarrow> Q x) \<Longrightarrow> Q (LEAST i. Ord i \<and> P i)"
   by (blast intro: Ord_LeastI_ex Ord_Least)
 
 lemma Ord_LeastI2_wellorder:
   assumes "Ord a" "P a"
   and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
   shows "Q (LEAST i. Ord i \<and> P i)"
 proof (rule LeastI2_order)
   show "Ord (LEAST i. Ord i \<and> P i) \<and> P (LEAST i. Ord i \<and> P i)"
     using Ord_Least Ord_LeastI assms by auto
 next
   fix y assume "Ord y \<and> P y" thus "(LEAST i. Ord i \<and> P i) \<le> y"
     by (simp add: Ord_Least_le)
 next
   fix x assume "Ord x \<and> P x" "\<forall>y. Ord y \<and> P y \<longrightarrow> x \<le> y" thus "Q x"
     by (simp add: assms(3))
 qed
 
 lemma Ord_LeastI2_wellorder_ex:
   assumes "\<exists>x. Ord x \<and> P x"
   and "\<And>a. \<lbrakk> P a; \<forall>b. Ord b \<and> P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
   shows "Q (LEAST i. Ord i \<and> P i)"
 using assms by clarify (blast intro!: Ord_LeastI2_wellorder)
 
 lemma not_less_Ord_Least: "\<lbrakk>k < (LEAST x. Ord x \<and> P x); Ord k\<rbrakk> \<Longrightarrow> \<not> P k"
   using Ord_Least_le less_le_not_le by auto
 
 lemma exists_Ord_Least_iff: "(\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha>) \<longleftrightarrow> (\<exists>\<alpha>. Ord \<alpha> \<and> P \<alpha> \<and> (\<forall>\<beta> < \<alpha>. Ord \<beta> \<longrightarrow> \<not> P \<beta>))" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs thus ?lhs by blast
 next
   assume H: ?lhs then obtain \<alpha> where \<alpha>: "Ord \<alpha>" "P \<alpha>" by blast
   let ?x = "LEAST \<alpha>. Ord \<alpha> \<and> P \<alpha>"
   have "Ord ?x"
     by (metis Ord_Least \<alpha>)
   moreover
   { fix \<beta> assume m: "\<beta> < ?x" "Ord \<beta>"
     from not_less_Ord_Least[OF m] have "\<not> P \<beta>" . }
   ultimately show ?rhs
     using Ord_LeastI_ex[OF H] by blast
 qed
 
 lemma Ord_mono_imp_increasing:
   assumes fun_hD: "h \<in> D \<rightarrow> D"
     and mono_h: "strict_mono_on h D" 
     and "D \<subseteq> ON" and \<nu>: "\<nu> \<in> D"
   shows "\<nu> \<le> h \<nu>"
 proof (rule ccontr)
   assume non: "\<not> \<nu> \<le> h \<nu>"
   define \<mu> where "\<mu> \<equiv> LEAST \<mu>. Ord \<mu> \<and> \<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
   have "Ord \<nu>"
     using \<nu> \<open>D \<subseteq> ON\<close> by blast
   then have \<mu>: "\<not> \<mu> \<le> h \<mu> \<and> \<mu> \<in> D"
     unfolding \<mu>_def by (rule Ord_LeastI) (simp add: \<nu> non)
   have "Ord (h \<nu>)"
     using assms by auto
   then have "Ord (h (h \<nu>))"
     by (meson ON_imp_Ord \<nu> assms funcset_mem)
   have "Ord \<mu>"
     using \<mu> \<open>D \<subseteq> ON\<close> by blast
   then have "h \<mu> < \<mu>"
     by (metis ON_imp_Ord Ord_linear2 PiE \<mu> \<open>D \<subseteq> ON\<close> fun_hD)
   then have "\<not> h \<mu> \<le> h (h \<mu>)"
     using \<mu> fun_hD mono_h by (force simp: strict_mono_on_def)
   moreover have *: "h \<mu> \<in> D"
     using \<mu> fun_hD by auto
   moreover have "Ord (h \<mu>)"
     using \<open>D \<subseteq> ON\<close> * by blast
   ultimately have "\<mu> \<le> h \<mu>"
     by (simp add: \<mu>_def Ord_Least_le)
   then show False
     using \<mu> by blast
 qed
 
 lemma le_Sup_iff:
   assumes "A \<subseteq> ON" "Ord x" "small A" shows "x \<le> \<Squnion>A \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>a\<in>A. y < a))"
 proof (intro iffI ballI impI)
   show "\<exists>a\<in>A. y < a"
     if "x \<le> \<Squnion> A" "y \<in> ON" "y < x"
     for y
   proof -
     have "\<not> \<Squnion> A \<le> y" "Ord y"
       using that by auto
     then show ?thesis
       by (metis Ord_linear2 Sup_least \<open>A \<subseteq> ON\<close> mem_Collect_eq subset_eq)
   qed
   show "x \<le> \<Squnion> A"
     if "\<forall>y\<in>ON. y < x \<longrightarrow> (\<exists>a\<in>A. y < a)"
     using that assms
     by (metis Ord_Sup Ord_linear_le Sup_upper less_le_not_le mem_Collect_eq subsetD)
 qed
 
 lemma le_SUP_iff: "\<lbrakk>f ` A \<subseteq> ON; Ord x; small A\<rbrakk> \<Longrightarrow> x \<le> \<Squnion>(f ` A) \<longleftrightarrow> (\<forall>y \<in> ON. y<x \<longrightarrow> (\<exists>i\<in>A. y < f i))"
   by (simp add: le_Sup_iff)
 
 subsection\<open>Transfinite Recursion and the V-levels\<close>
 
 definition transrec :: "[[V\<Rightarrow>V,V]\<Rightarrow>V, V] \<Rightarrow> V"
   where "transrec H a \<equiv> wfrec {(x,y). x \<in> elts y} H a"
 
 lemma transrec: "transrec H a = H (\<lambda>x \<in> elts a. transrec H x) a"
 proof -
   have "(cut (wfrec {(x, y). x \<in> elts y} H) {(x, y). x \<in> elts y} a)
       = (\<lambda>x\<in>elts a. wfrec {(x, y). x \<in> elts y} H x)"
     by (force simp: cut_def)
   then show ?thesis
     unfolding transrec_def
     by (simp add: foundation wfrec)
 qed
 
 text\<open>Avoids explosions in proofs; resolve it with a meta-level definition\<close>
 lemma def_transrec:
     "\<lbrakk>\<And>x. f x \<equiv> transrec H x\<rbrakk> \<Longrightarrow> f a = H(\<lambda>x \<in> elts a. f x) a"
   by (metis restrict_ext transrec)
 
 lemma eps_induct [case_names step]:
   assumes "\<And>x. (\<And>y. y \<in> elts x \<Longrightarrow> P y) \<Longrightarrow> P x"
   shows "P a"
   using wf_induct [OF foundation] assms by auto
 
 
 definition Vfrom :: "[V,V] \<Rightarrow> V"
   where "Vfrom a \<equiv> transrec (\<lambda>f x. a \<squnion> \<Squnion>((\<lambda>y. VPow(f y)) ` elts x))"
 
 abbreviation Vset :: "V \<Rightarrow> V" where "Vset \<equiv> Vfrom 0"
 
 lemma Vfrom: "Vfrom a i = a \<squnion> \<Squnion>((\<lambda>j. VPow(Vfrom a j)) ` elts i)"
   apply (subst Vfrom_def)
   apply (subst transrec)
   using Vfrom_def by auto
 
 lemma Vfrom_0 [simp]: "Vfrom a 0 = a"
   by (subst Vfrom) auto
 
 lemma Vset: "Vset i = \<Squnion>((\<lambda>j. VPow(Vset j)) ` elts i)"
   by (subst Vfrom) auto
 
 lemma Vfrom_mono1:
   assumes "a \<le> b" shows "Vfrom a i \<le> Vfrom b i"
 proof (induction i rule: eps_induct)
   case (step i)
-  then have "a \<squnion> (SUP j\<in>elts i. VPow (Vfrom a j)) \<le> b \<squnion> (SUP j\<in>elts i. VPow (Vfrom b j))"
+  then have "a \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom a j)) \<le> b \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom b j))"
     by (intro sup_mono cSUP_subset_mono \<open>a \<le> b\<close>) auto
   then show ?case
     by (metis Vfrom)
 qed
 
 lemma Vfrom_mono2: "Vfrom a i \<le> Vfrom a (i \<squnion> j)"
 proof (induction arbitrary: j rule: eps_induct)
   case (step i)
-  then have "a \<squnion> (SUP j\<in>elts i. VPow (Vfrom a j))
-           \<le> a \<squnion> (SUP j\<in>elts (i \<squnion> j). VPow (Vfrom a j))"
+  then have "a \<squnion> (\<Squnion>j\<in>elts i. VPow (Vfrom a j))
+           \<le> a \<squnion> (\<Squnion>j\<in>elts (i \<squnion> j). VPow (Vfrom a j))"
     by (intro sup_mono cSUP_subset_mono order_refl) auto
   then show ?case
     by (metis Vfrom)
 qed
 
 lemma Vfrom_mono: "\<lbrakk>Ord i; a\<le>b; i\<le>j\<rbrakk> \<Longrightarrow> Vfrom a i \<le> Vfrom b j"
   by (metis (no_types) Vfrom_mono1 Vfrom_mono2 dual_order.trans sup.absorb_iff2)
 
 lemma Transset_Vfrom: "Transset(A) \<Longrightarrow> Transset(Vfrom A i)"
 proof (induction i rule: eps_induct)
   case (step i)
   then show ?case
     by (metis Transset_SUP Transset_VPow Transset_sup Vfrom)
 qed
 
 lemma Transset_Vset [simp]: "Transset(Vset i)"
   by (simp add: Transset_Vfrom)
 
 lemma Vfrom_sup: "Vfrom a (i \<squnion> j) = Vfrom a i \<squnion> Vfrom a j"
 proof (rule order_antisym)
   show "Vfrom a (i \<squnion> j) \<le> Vfrom a i \<squnion> Vfrom a j"
     by (simp add: Vfrom [of a "i \<squnion> j"] Vfrom [of a i] Vfrom [of a j] Sup_Un_distrib image_Un sup.assoc sup.left_commute)
   show "Vfrom a i \<squnion> Vfrom a j \<le> Vfrom a (i \<squnion> j)"
     by (metis Vfrom_mono2 le_supI sup_commute)
 qed
 
 lemma Vfrom_succ_Ord:
   assumes "Ord i" shows "Vfrom a (succ i) = a \<squnion> VPow(Vfrom a i)"
 proof (cases "i = 0")
   case True
   then show ?thesis
     by (simp add: Vfrom [of _ "succ 0"])
 next
   case False
-  have *: "(SUP x\<in>elts i. VPow (Vfrom a x)) \<le> VPow (Vfrom a i)"
+  have *: "(\<Squnion>x\<in>elts i. VPow (Vfrom a x)) \<le> VPow (Vfrom a i)"
   proof (rule cSup_least)
     show "(\<lambda>x. VPow (Vfrom a x)) ` elts i \<noteq> {}"
       using False by auto
     show "x \<le> VPow (Vfrom a i)" if "x \<in> (\<lambda>x. VPow (Vfrom a x)) ` elts i" for x
       using that
       by clarsimp (meson Ord_in_Ord Ord_linear_le Vfrom_mono assms mem_not_refl order_refl vsubsetD)
   qed
   show ?thesis
   proof (rule Vfrom [THEN trans])
-    show "a \<squnion> (SUP j\<in>elts (succ i). VPow (Vfrom a j)) = a \<squnion> VPow (Vfrom a i)"
+    show "a \<squnion> (\<Squnion>j\<in>elts (succ i). VPow (Vfrom a j)) = a \<squnion> VPow (Vfrom a i)"
       using assms
       by (intro sup_mono order_antisym) (auto simp: Sup_V_insert *)
   qed
 qed
 
 lemma Vset_succ: "Ord i \<Longrightarrow> Vset(succ(i)) = VPow(Vset(i))"
   by (simp add: Vfrom_succ_Ord)
 
 lemma Vfrom_Sup:
   assumes "X \<noteq> {}" "small X"
-  shows "Vfrom a (Sup X) = (SUP y\<in>X. Vfrom a y)"
+  shows "Vfrom a (Sup X) = (\<Squnion>y\<in>X. Vfrom a y)"
 proof (rule order_antisym)
-  have "Vfrom a (\<Squnion> X) = a \<squnion> (SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
+  have "Vfrom a (\<Squnion> X) = a \<squnion> (\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
     by (metis Vfrom)
   also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
   proof -
     have "a \<le> \<Squnion> (Vfrom a ` X)"
       by (metis Vfrom all_not_in_conv assms bdd_above_iff_small cSUP_upper2 replacement sup_ge1)
-    moreover have "(SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j)) \<le> \<Squnion> (Vfrom a ` X)"
+    moreover have "(\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j)) \<le> \<Squnion> (Vfrom a ` X)"
     proof -
       have "VPow (Vfrom a x) \<le> \<Squnion> (Vfrom a ` X)"
         if "y \<in> X" "x \<in> elts y" for x y
       proof -
         have "VPow (Vfrom a x) \<le> Vfrom a y"
           by (metis Vfrom bdd_above_iff_small cSUP_upper2 le_supI2 order_refl replacement small_elts that(2))
         also have "\<dots> \<le> \<Squnion> (Vfrom a ` X)"
           using assms that by (force intro: cSUP_upper)
         finally show ?thesis .
       qed
       then show ?thesis
         by (simp add: SUP_le_iff \<open>small X\<close>)
     qed
     ultimately show ?thesis
       by auto
   qed
   finally show "Vfrom a (\<Squnion> X) \<le> \<Squnion> (Vfrom a ` X)" .
   have "\<And>x. x \<in> X \<Longrightarrow>
-         a \<squnion> (SUP j\<in>elts x. VPow (Vfrom a j))
-         \<le> a \<squnion> (SUP j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
+         a \<squnion> (\<Squnion>j\<in>elts x. VPow (Vfrom a j))
+         \<le> a \<squnion> (\<Squnion>j\<in>elts (\<Squnion> X). VPow (Vfrom a j))"
     using cSUP_subset_mono \<open>small X\<close> by auto
   then show "\<Squnion> (Vfrom a ` X) \<le> Vfrom a (\<Squnion> X)"
     by (metis Vfrom assms(1) cSUP_least)
 qed
 
 lemma Limit_Vfrom_eq:
-    "Limit(i) \<Longrightarrow> Vfrom a i = (SUP y \<in> elts i. Vfrom a y)"
+    "Limit(i) \<Longrightarrow> Vfrom a i = (\<Squnion>y \<in> elts i. Vfrom a y)"
   by (metis Limit_def Limit_eq_Sup_self Vfrom_Sup ex_in_conv small_elts)
 
 end