Theory Cstar_Algebra_On

section ‹$C^*$-algebras›

theory Cstar_Algebra_On
  imports
    Lie_Groups.Algebra_On
    Types_To_Sets_Extension.SML_Topological_Space
    Complex_Bounded_Operators.Complex_Vector_Spaces
    "HOL-Analysis.Abstract_Metric_Spaces"
begin

bundle scaleC_syntax begin
  notation Complex_Vector_Spaces0.scaleC_class.scaleC (infixr *C 75)
end

unbundle no scaleC_syntax


subsection ‹Additional lemmas for theoryLie_Groups.Algebra_On

lemma (in algebra_on)
  shows distR': "xS; yS; zS  (x-y)  z = x  z - y  z"
    and distL': "xS; yS; zS  z  (x-y) = z  x - z  y"
  using distR m1.mem_uminus apply fastforce
  using distL m1.mem_uminus by fastforce


subsection ‹Involutive rings and algebras›

locale involutive_semigroup = semigroup_add_on_with +
  fixes involution :: "'a'a" (‹_ [99] 100)
  assumes involution[simp]: "xS  (x) = x"
    and antiautomorphism: "xS; yS  (pls x y) = pls (y) (x)"
    and involution_mem[simp]: "xS  x  S"


― ‹Bundle for class constant notation (e.g. for constplus):
  disable inside Ballarin's set-based locale for rings,
  re-enable once we involve type classes for e.g. base fields of algebras.›
bundle class_ring_notation begin
  notation plus (infixl "+" 65)
  notation minus (infixl - 65)
  notation uminus ((‹open_block notation=‹prefix -››- _) [81] 80)
end

unbundle no class_ring_notation
locale involutive_ring =
    Ring_Theory.ring R addition multiplication zero unit +
    involutive_semigroup R multiplication involution
  for R :: "'a set" and addition :: "'a'a'a" (infixl "+" 65)
    and multiplication (infixl "" 70) and zero ("𝟬") and unit ("𝟭")
    and involution :: "'a'a" (‹_ [99] 100) +
  assumes ivl_ring: "xR; yR  (x+y) = x + y"
begin

  lemma unit_self_adjoint: "𝟭 = 𝟭"
    using antiautomorphism[of _ 𝟭] involution involution_mem
    by (metis multiplicative.right_unit multiplicative.unit_closed)

  lemma ivl_uminus: "xR  involution (-x) = - involution x"
    by (metis (no_types, lifting) additive.inverse_equality additive.invertible additive.invertibleE
        additive.invertible_left_inverse2 additive.unit_closed involution_mem ivl_ring)

  lemma ivl_minus: "xR; yR  involution (x-y) = involution x - involution y"
    by (simp add: ivl_ring ivl_uminus)

end
unbundle class_ring_notation

text ‹A general definition of $^*$-algebra might look as follows.

\begin{definition}[$^*$-algebra]
Let $A$ be a ring with involution $^*$, and $R$ any commutative ring with involution $'$.
$A$ is a $^*$-algebra if it is an associative algebra over $R$, such that:
\[
\forall r \in R. \forall a \in A. (r a)^* = r' a^*
\]
A \emph{$^*$-homomorphism} $f\colon A \to B$ is an algebra homomorphism that respects involution:
\[ \forall a \in A. f(a)^{*_B} = f(a^{*_A}) \]
\end{definition}

Since nearly all formalisation seems to use classes for the vector addition and base field,
and some texts (e.g. \cite{fewster2019}) define $^*$-algebras using the complex numbers as
a base ring directly, we do so as well, without worrying about the involution of the base ring
being specified only implicitly, on a type-level. Even category theory is, most of the time,
only interested in categories of spaces over a shared base field/ring.
Note also our involutive complex algebras are unital (and associative).›


locale involutive_complex_algebra =
  assoc_algebra_1_on S scale multiplication unit +
  involutive_ring S "(+)" multiplication 0 unit involution
  for S :: "'a::ab_group_add set"
    and scale :: "complex  'a  'a"  (infixr *C 75)
    and multiplication :: "'a  'a  'a"  (infixr  74)
    and unit :: "'a" (𝟭)
    and involution :: "'a'a" (‹_ [99] 100) +
  assumes ivl_scale: "sS  (c *C s) = cnj c *C s"


lemma involutive_complex_algebraI:
  fixes S :: "'a::ab_group_add set"
    and scl :: "complex  'a  'a"
    and mlt :: "'a  'a  'a"
    and e :: "'a"
    and involution :: "'a'a"
  assumes "assoc_algebra_1_on S scl mlt e"
    and involution: "x. xS  involution (involution x) = x"
    and antiautomorphism: "x y. xS  yS  involution (mlt x y) = mlt (involution y) (involution x)"
    and ivl_mem: "x. xS  involution x  S"
    and ivl_ring: "x y. xS yS  involution (x+y) = (involution x) + (involution y)"
    and ivl_scale: "x c. xS  involution (scl c x) = scl (cnj c) (involution x)"
  shows "involutive_complex_algebra S scl mlt e involution"
proof -
  interpret alg: assoc_algebra_1_on S scl mlt e using assms(1).
  interpret mon: Group_Theory.monoid S "(+)" 0
    by (unfold_locales, simp_all add: group_cancel.add1 alg.m1.mem_add alg.m1.mem_zero)
  have "mon.invertible u" if "u  S" for u
    by (meson ab_left_minus alg.m1.mem_uminus mon.invertibleI neg_eq_iff_add_eq_0 that)
  then show "involutive_complex_algebra S scl mlt e involution"
    by (unfold_locales, simp_all add: alg.m1.subspace_UNIV alg.m1.subspace_add add.commute
        add.left_commute alg.amult_assoc alg.distL alg.distR assms(2-))
qed

lemma (in module_on) sub_module:
  assumes "subspace A" "AS"
  shows "module_on A scale"
  using assms module_on.intro module_on.subspace_def module_on_axioms scale_left_distrib_on
    scale_one_on scale_right_distrib_on scale_scale_on subset_eq by (smt (verit, ccfv_threshold))

locale involutive_subalgebra =
  subalg: involutive_complex_algebra A + involutive_complex_algebra B for A B +
  assumes "A  B"

lemma (in involutive_complex_algebra) subalgebraI:
  fixes A
    assumes unital_subspace: "m1.subspace A" "A  S" "𝟭  A"
      and mult_closed: "x y. x  A  y  A  x  y  A"
      and involution_closed: "x. x  A  involution x  A"
  shows "involutive_subalgebra (*C) (⦁) 𝟭 involution A S"
proof -
  interpret vector_space_on A
    using m1.sub_module unital_subspace(1,2) vector_space_on.intro by blast
  
  interpret subalg: assoc_algebra_1_on A "(*C)" "(⦁)" 𝟭
    apply unfold_locales
             apply (meson in_mono linearL'(2) unital_subspace(2))
            apply (meson unital_subspace(2) in_mono linearL'(1))
           apply (meson distributive(1) in_mono unital_subspace(2))
          apply (meson unital_subspace(2) linearR'(1) subsetD)
         using assms(4) apply blast
        using unital_subspace(2) apply blast
       apply (simp add: unital_subspace(3))
      using unital_subspace(2) apply blast
     using unital_subspace(2) apply blast
    by simp

  interpret ivl_subalg: involutive_complex_algebra A
    apply (intro involutive_complex_algebraI)
    subgoal by unfold_locales
    using involution unital_subspace(2) apply blast
    apply (meson antiautomorphism in_mono unital_subspace(2))
    using involution_closed apply blast
    apply (meson ivl_ring subset_eq unital_subspace(2))
    using assms(2) ivl_scale by blast

  show ?thesis
    by (unfold_locales, simp add: assms(2))
qed
    


subsection ‹Preliminaries and experiments›

context Metric_space begin

sublocale topological_space_ow M mopen
  apply unfold_locales
  subgoal by (simp add: gt_ex mball_subset_mspace mopen_def)
  subgoal by (metis mopen_def openin_Int openin_mtopology)
  subgoal using openin_Union[of _ mtopology] by (simp add: mtopology_def)
  done

end


subsection ‹Subfields of a classfield on a type universe›
text ‹Compare to termsubspace in theoryHOL-Types_To_Sets.Linear_Algebra_On.›

abbreviation "closed_under_un K op  xK. op x  K"
abbreviation "closed_under_bin K op  xK. yK. op x y  K"

locale subfield =
  fixes K :: "'a::field set"
  assumes subfield_1[simp]: "1  K"
  and subfield_closed[simp]:
    "xK  - x  K"
    "xK  inverse x  K"
    "xK; yK  x + y  K"
    "xK; yK  x * y  K"
begin

― ‹The zero element of a field coincides with the zero element of any of its subfields. Since
  term0 is a class constant, it is always the zero element of the field on the type universe.›
lemma subfield_0 [simp]: "0  K"
  by (metis add.right_inverse subfield_1 subfield_closed(1,3))

end


― ‹Any field is a subfield of itself.›
lemma subfield_UNIV: "subfield UNIV"
  unfolding subfield_def by simp

― ‹The real numbers are a subfield of the complex numbers.›
lemma real_subfield_complex: "subfield {c. Im c = 0}"
  unfolding subfield_def by auto


subsubsection ‹... as a transfer relation?›
text ‹The price of being able to talk about a subfield of a different type is representational
  definiteness. The subfield of type 'a is only a subfield ``up to isomorphism". Quite categorical
  in flavour, this should make no practical difference. See also skeletal categories:
  https://ncatlab.org/nlab/show/skeleton›
context includes lifting_syntax begin

definition "subfield_rel (R :: 'a::field  'b::field  bool) 
    left_total R  bi_unique R     ⌦‹inj_on R (UNIV::'a set)›
    R 1 1 
    (R ===> R ===> R) (+) (+) 
    (R ===> R ===> R) (*) (*) 
    (R ===> R) uminus uminus 
    (R ===> R) inverse inverse"
    (* ... etc for all operations ...*)

lemma subfield_rel_0: "R 0 0" if "subfield_rel R"
  using add.right_inverse by (metis rel_funD that[unfolded subfield_rel_def])

lemma subfield_rel_UNIV: "subfield_rel (=)"
  by (simp add: bi_unique_eq left_total_eq rel_fun_eq subfield_rel_def)

lemma real_subfield_rel_complex: "subfield_rel (λr c. complex_of_real r = c)"
  using of_real_add of_real_mult by (simp add: left_total_def bi_unique_def subfield_rel_def rel_fun_def)

end (* lifting_syntax *)


subsection ‹Topological Fields and Vector Spaces›
text ‹
  The topology will be defined, as usual for locales, on a carrier set only.
  Here, that carrier is implicit as the union of all open sets, like for manifolds.
  This means e.g. addition is defined on the type universe, but is continuous only on the
  subset of that universe covered by the topology.
›

abbreviation "continuous_binary_op t f  continuous_map (prod_topology t t) t (λ(a,b). f a b)"
locale topological_field_ow = topological_space_ow F τ
  for F :: "'at::field set"
    and τ :: "'at set  bool" +
  assumes continuous_plus: "continuous_binary_op (topology τ) (+)"
    and continuous_times: "continuous_binary_op (topology τ) (*)"
    and continuous_uminus: "continuous_map (topology τ) (topology τ) uminus"
    and continuous_inverse: "continuous_map (topology τ) (topology τ) inverse"
begin
text ‹
  A somewhat Frankensteinian construction.
  The locale localetopological_space_ow is taken from the ETTS-powered
  theoryTypes_To_Sets_Extension.SML_Topological_Space, and transferred from
  classTopological_Spaces.topological_space. By contrast, termcontinuous_map stems from
  theoryHOL-Analysis.Abstract_Topology. The field operations are still class constants,
  similarly to localevector_space_on, with topological properties on the carrier termF only.
›
end

locale topological_vector_space_on =
    vector_space_on V scale +
    topological_space_ow V τV +
    top_F: topological_field_ow F τF
  for F :: "'a::field set" and τF :: "'a set  bool"
    and V :: "'b::ab_group_add set"
    and scale :: "'a  'b  'b" (infixr "*s" 75)
    and τV :: "'b set  bool" +
  assumes continuous_add: "continuous_binary_op (topology τV) (+)"
    and continuous_scale: "continuous_map (prod_topology (topology τF) (topology τV)) (topology τV) (λ(a,v). scale a v)"


subsection ‹Normed Fields and Vector Spaces›

― ‹We can equip a (sub)field with a norm on its carrier set.›
locale normed_field = subfield F for F :: "'a::field set" +
  fixes norm :: "'areal" ("_" 100)
  assumes normed_field: "xF  x  0"
    "xF  x = 0  x = 0"
    "xF  -x = x"
    "xF; yF  x+y  x+y"
    "xF; yF  x*y  x*y"


locale valued_field = normed_field +
  assumes multiplicative_norm: "xF; yF  x*y = x*y"
begin

lemma norm_1 [simp]: "1 = 1"
  by (metis mult_cancel_right1 multiplicative_norm normed_field(2) subfield_1 zero_neq_one)

end

locale seminormed_vector_space_on =
    vector_space_on V scale +
    F: valued_field F field_abs
  for F :: "'f::field set" and field_abs :: "'freal" ("_" [80])
    and V :: "'v::ab_group_add set" and scale :: "'f'v'v" +
  fixes vector_norm :: "'v::ab_group_add  real" ("_" [65]) ― ‹At priority 65, you can write sums inside the norm.›
  assumes triangle_add: "xV; yV 
      vector_norm (x+y)  vector_norm x + vector_norm y"
    and absolute_homogeneous: "aF; xV 
      vector_norm (scale a x) = (field_abs a) * (vector_norm x)"
begin

lemma norm_0: "vector_norm 0 = 0"
  using absolute_homogeneous[of 0 0] F.normed_field(2) scale_zero_left mem_zero F.subfield_0
  by fastforce

lemma norm_uminus: "-x = x" if x: "x  V"
proof -
  have "-x = -1 * x"
    using absolute_homogeneous[OF _ x, of "-1"] by (simp add: scale_minus_left_on x)
  then show "-x = x"
    using F.normed_field(3)[OF F.subfield_1] absolute_homogeneous x by simp
qed

lemma norm_nonneg [simp]: "xV  x  0"
  using mem_uminus norm_0 norm_uminus triangle_add
  by fastforce

end


locale normed_vector_space_on = seminormed_vector_space_on +
  assumes positive_definite: "xV; vector_norm x = 0  x = 0"
begin

lemma norm_0_iff: "vector_norm x = 0  x = 0" if "xV"
  using positive_definite norm_0 that by blast

abbreviation (input) induced_metric
  where "induced_metric x y  y-x"

text ‹The locale localeMetric_space, which we would like to instantiate, requires things like
  terminduced_metric x y  0. This is not true in general: @{thm norm_nonneg} only guarantees
  this behaviour inside the carrier set. Thus we have to ``totalise'' the induced metric for use
  in the existing localeMetric_space, by defining behaviour outside the carrier set to satisfy
  the axioms of the locale.›

definition totalized_induced_metric ("𝖽")
(* TODO move defn to seminormed_space - it induces a topology which is Hausdorff iff d is a norm:
    https://en.wikipedia.org/wiki/Seminorm#Pseudometrics_and_the_induced_topology *)
  where "𝖽 x y  if xV  yV then induced_metric x y else 0"

lemma induced_metric_simps [simp]:
  "xV; yV  𝖽 x y = induced_metric x y"
  "xV  𝖽 x y = 0"
  "yV  𝖽 x y = 0"
  by (simp_all add: totalized_induced_metric_def)

lemma metric_translation_invariant: "xV; yV; zV  𝖽 x y = 𝖽 (x+z) (y+z)"
  by (simp add: mem_add)
lemma metric_translation_invariant': "xV; yV  𝖽 x y = 𝖽 (x-y) 0"
  using mem_add mem_uminus mem_zero by fastforce

sublocale Metric_space V 𝖽
proof
  fix x y z
  show "0  𝖽 x y"
    using mem_add mem_uminus norm_nonneg
    by (metis ab_group_add_class.ab_diff_conv_add_uminus induced_metric_simps le_numeral_extra(3))
  show "𝖽 x y = 𝖽 y x"
    by (metis mem_add mem_uminus minus_diff_eq norm_uminus totalized_induced_metric_def uminus_add_conv_diff)
  assume x: "xV" and y: "yV"
  thus "𝖽 x y = 0  x = y"
    by simp (metis diff_conv_add_uminus eq_iff_diff_eq_0 mem_add mem_uminus norm_0_iff)
  assume z: "zV"
  have "z - x = (z-y) + (y-x)" by simp
  also have "  z - y + y - x" (* TODO move to seminorm? *)
    using triangle_add[of "z-y" "y-x"] by (metis diff_conv_add_uminus mem_add mem_uminus x y z)
  finally show "𝖽 x z  𝖽 x y + 𝖽 y z"
    using x y z by simp
qed

end


lemma totalized_induced_metric_eq_dist:
  "normed_vector_space_on.totalized_induced_metric UNIV norm = dist"
proof -
  interpret normed_vector_space_on UNIV abs "UNIV :: 'a set" scaleR norm
    apply unfold_locales apply simp_all
    using scaleR_right.add apply blast
    using module.scale_left_distrib module_axioms apply blast
    apply (simp add: abs_mult)
    using abs_mult apply blast
    using norm_triangle_ineq by blast
  show "totalized_induced_metric = dist"
    unfolding totalized_induced_metric_def
    by (auto simp add: Met_TC.commute simp flip: dist_norm)
qed


term x::'a::real_normed_vector

locale banach_space_on = normed_vector_space_on +
  assumes "mcomplete"

thm class.cbanach_def
lemma cbanach_is_banach_space_on:
  shows "banach_space_on UNIV cmod (UNIV::'cb::cbanach set) scaleC norm"
  apply unfold_locales apply simp_all
  subgoal using complex_vector.vector_space_assms(1) by blast
  subgoal using complex_vector.vector_space_assms(2) by blast
  subgoal using norm_triangle_ineq by blast
  subgoal using norm_mult_ineq by blast
  subgoal using norm_mult by blast
  subgoal by (simp add: norm_triangle_ineq)
  subgoal
    unfolding totalized_induced_metric_eq_dist mcomplete_iff_complete
    by (simp add: complete_UNIV)
  done


subsection ‹C* algebras›

(* TODO decompose into normed algebra, Banach, B*, etc *)
locale Cstar_algebra =
    banach_space_on F cmod V scale vector_norm +
(* TODO only complex: should at least be any subfield of the complex numbers, but could probably be more general *)
    involutive_complex_algebra V scale multiplication unit involution
  for F :: "complex set"
    and V :: "'v::ab_group_add set"
    and scale :: "complex  'v  'v"  (infixr *C 75)
    and multiplication :: "'v  'v  'v"  (infixr  74)
    and vector_norm :: "'v  real"  (_ [65])
    and unit :: "'v" (𝟭)
    and involution :: "'v'v" (‹_ [99] 100) +
  assumes normed_algebra : "A B. AV; BV  AB  A * B"
  assumes normed_unital: "𝟭 = 1"
  assumes involution_isometric: "A. AV  A = A"
  assumes Cstar: "A. AV  (A)  A = A * A"
begin

lemma Bstar: "(A)  A = A2" if "AV" for A
  using Cstar[OF that]
  unfolding involution_isometric[OF that] power2_eq_square .

end


lemma Bstar_implies_isometric:
  assumes "seminormed_vector_space_on F cmod V scale vector_norm"
    "involutive_complex_algebra V scale multiplication unit involution"
    and "A B. AV; BV  vector_norm (multiplication A B)  vector_norm A * vector_norm B" "vector_norm unit = 1"
    and "A. AV  vector_norm (multiplication (involution A) A) = (vector_norm A)2"
    and "AV"
  shows "vector_norm (involution A) = vector_norm A"
proof -
  interpret seminormed_vector_space_on F cmod V scale vector_norm
    using assms(1) .
  interpret involutive_complex_algebra V scale multiplication unit involution
    using assms(2) .
  from assms(3)[of "involution A" A]
  have "(vector_norm A)2  vector_norm (involution A) * vector_norm A"
    by (simp add: assms(5,6))
  hence ineq_1: "(vector_norm A)  vector_norm (involution A)"
    unfolding power2_eq_square 
    using norm_nonneg[OF involution_mem[OF assms(6)]]
    using nle_le
    by (smt (verit, ccfv_SIG) mult_mono vector_space_over_itself.scale_cancel_right)
  from assms(3)[of A "involution A"]
  have "(vector_norm (involution A))2  vector_norm A * vector_norm (involution A)"
    by (metis assms(5,6) involution involution_mem)
  hence ineq_2: "(vector_norm (involution A))  vector_norm A"
    unfolding power2_eq_square 
    using norm_nonneg[OF assms(6)]
    using linorder_not_le by fastforce
  from ineq_1 ineq_2 show ?thesis by force
qed




locale Cstar_subalgebra =
  subalg: Cstar_algebra _ A + Cstar_algebra _ B for A B +
assumes "A  B"
  

lemma (in banach_space_on) closed_iff_complete:
  assumes "A  V"
  shows "closedin mtopology A  Metric_space.mcomplete A 𝖽"
proof -
  interpret sub_A: Submetric V 𝖽 A
    using assms by unfold_locales
  show ?thesis
    using sub_A.closedin_eq_mcomplete assms banach_space_on_axioms
    by (simp add: banach_space_on_def banach_space_on_axioms_def)
qed

lemma (in normed_vector_space_on) from_subspace:
  assumes "subspace A" "AV"
  shows "normed_vector_space_on F field_abs A scale vector_norm"
proof -
  interpret VS: vector_space_on A scale
    by (simp add: assms sub_module vector_space_on_alt_def)
  show ?thesis
    apply unfold_locales
    using absolute_homogeneous assms(2) positive_definite triangle_add by (auto simp: in_mono)
qed

text ‹Not particularly elegantly or generally written: it doesn't matter which (induced) metric we use,
  because all cases outside of the subspace carrier A don't matter. Used for C*-subalgebra intro lemma.›
lemma (in normed_vector_space_on) mcomplete_submetric_equal:
  assumes "A  V" "subspace A"
  shows "Metric_space.mcomplete A (normed_vector_space_on.totalized_induced_metric A vector_norm) = Metric_space.mcomplete A 𝖽"
proof -
  interpret VS_A: normed_vector_space_on _ _ A
    using from_subspace[OF assms(2,1)] .
  interpret met_A: Metric_space A 𝖽
    apply unfold_locales
    using nonneg commute assms(1) zero triangle subset_iff by (auto simp: in_mono)
  have tot_met_simp: "VS_A.totalized_induced_metric x y = totalized_induced_metric x y" if "xA" "yA" for x y
    using assms(1) that totalized_induced_metric_def by auto
  have mball_local_simp: "VS_A.mball x r = met_A.mball x r" for x r
    using tot_met_simp by auto
  show ?thesis
    unfolding VS_A.mcomplete_def met_A.mcomplete_def
    unfolding VS_A.MCauchy_def met_A.MCauchy_def
    unfolding VS_A.mtopology_def met_A.mtopology_def
    unfolding VS_A.mopen_def met_A.mopen_def
    apply (subst mball_local_simp)
    using tot_met_simp by (auto simp: range_subsetD)
qed

lemma (in banach_space_on) closed_iff_complete':
  defines "complete_in_induced_submetric 
      λA n. Metric_space.mcomplete A (normed_vector_space_on.totalized_induced_metric A n)"
  assumes "A  V" "subspace A"
  shows "closedin mtopology A  complete_in_induced_submetric A vector_norm"
  using closed_iff_complete mcomplete_submetric_equal assms by simp

lemma (in Cstar_algebra) subalgebraI:
  fixes A
    assumes unital_subalgebra: "subspace A" "A  V" "𝟭  A"
      and mult_closed: "x y. x  A  y  A  x  y  A"
      and involution_closed: "x. x  A  involution x  A"
      and closed_subset: "closedin mtopology A"
    shows "Cstar_subalgebra F scale (⦁) vector_norm 𝟭 involution A V"
proof -
  interpret involutive_subalgebra _ _ _ _ A V
    using subalgebraI[OF assms(1-5)] .
  show ?thesis
    apply unfold_locales
    using triangle_add unital_subalgebra(2) apply blast
    using absolute_homogeneous unital_subalgebra(2) apply blast
    using assms(2) positive_definite apply blast
    using closed_iff_complete'[OF assms(2,1)] closed_subset apply blast
    apply (meson assms(2) normed_algebra subset_iff)
    using normed_unital assms(2) involution_isometric Cstar by blast+
qed

lemma (in Cstar_algebra) subalgebraI':
  fixes A
    assumes unital_subalgebra: "subspace A" "A  V" "𝟭  A"
      and mult_closed: "x y. x  A  y  A  x  y  A"
      and involution_closed: "x. x  A  involution x  A"
      and complete_subset: "Metric_space.mcomplete A 𝖽"
    shows "Cstar_subalgebra F scale (⦁) vector_norm 𝟭 involution A V"
  using subalgebraI[OF assms(1-5)] assms(2,6) closed_iff_complete by blast


subsection ‹Cauchy-Schwarz Inequality for functionals on involutive algebras›
context involutive_complex_algebra begin

text ‹
  Disable the notation from sessionJacobson_Basic_Algebra that conflicts with underlying
  class constants used for our algebras.
›
no_notation additive.inverse ("- _" [66] 65)  ― ‹conflicts with termuminus_class.uminus
no_notation subtraction (infixl "-" 65)       ― ‹conflicts with termminus_class.minus

lemma additive_inverse_uminus[simp]:
  "additive.inverse A = - A" if "AS"
  by (simp add: additive.inverse_equality m1.mem_uminus that)

lemma subtraction_minus[simp]:
  "subtraction A B = A - B" if "AS" "BS"
  by (simp add: that(2))


declare ivl_uminus [[simp del]]
lemma involution_uminus'[simp]: "involution (- B) = - (involution B)" if "BS" for B
  using ivl_uminus by (simp add: that)

declare ivl_minus [[simp del]]
lemma ivl_minus'[simp]: "involution (A - B) = involution A - (involution B)"
  if "AS" "BS" for B
  using ivl_minus[OF that] by (simp add: that)

end


text ‹The nomenclature of ``functional'' is taken from operator algebras, where operators are often functions.
  Here ``positive'' is not strict: the corresponding axiom is named after non-negativity.›
locale positive_normalised_linear_functional =
    involutive_complex_algebra S scale multiplication unit involution +
    linear_on S UNIV scale "(*)" ω
  for S :: "'a::ab_group_add set"
    and scale :: "complex  'a  'a"  (infixr *C 75)
    and multiplication :: "'a  'a  'a"  (infixr  74)
    and unit :: "'a" (𝟭)
    and involution :: "'a'a" (‹_ 73)
    and ω :: "'acomplex" +
  assumes nonneg: "AS  ω ((A)  A)  0"
    and one [simp]: "ω 𝟭 = 1"
begin

(* TODO this should go in involutive_complex_algebra *)
notation cmod ("_") ― ‹termabs has omitted priority›

lemma nonneg':
  assumes "A  S"
  shows "Re (ω (involution A  A))  0" "Re (ω (A  involution A))  0" "Im (ω (A  involution A)) = 0" "Im (ω (involution A  A)) = 0"
  using nonneg assms involution involution_mem
  by (metis zero_complex.simps(1) Re_mono,
      metis zero_complex.simps(1) Re_mono,
      (metis comp_Im_same zero_complex.simps(2))+)

lemma involution_conjugate: "ω (involution A) = cnj (ω A)" if "A  S"
proof -
  have is_Real: "Im (α * ω A + cnj α * ω (involution A)) = 0" if "A  S" for α::complex and A
  proof -
    let ?s = "𝟭 + α *C A" ― ‹This is the crucial starting ``guess''.›
    note [simp] = m1.mem_scale
    have inS [simp]: "A  S" "involution A  S" "?s  S"
      by (simp_all add: that)
    have "?s  involution ?s = 𝟭  involution (𝟭 + α *C A) + α *C A  involution (𝟭 + α *C A)"
      by (simp add: distR[of 𝟭 "α *C A" "involution ?s"])
    also have " = 𝟭 + involution (α *C A) + α *C A + α *C A  involution (α *C A)"
      by (simp add: ivl_ring unit_self_adjoint algebra_simps distL)
    finally have "?s  involution ?s = 𝟭 + ¦α¦2 *C A(involution A) + α *C A + involution (α *C A)"
      using ivl_scale using complex_norm_square[of α] by (simp add: abs_complex_def mult.commute)
    then have "Im (α * ω A + cnj α * ω (involution A)) = Im (ω (?s  involution ?s))"
      by (simp add: abs_complex_def add scale ivl_scale nonneg'(3))
    then show ?thesis
      by (simp add: nonneg'(3))
  qed
  have re_im_decompose: "0 = Re a * (Im (ω A) + Im (ω (involution A))) + Im a * (Re (ω A) - Re (ω (involution A)))"
    for a::complex
    using is_Real[OF that, of a]
    by (simp add: vector_space_over_itself.scale_right_diff_distrib vector_space_over_itself.scale_right_distrib)
  have "Im (ω A) + Im (ω (involution A)) = 0" "Re (ω A) - Re (ω (involution A)) = 0"
    using re_im_decompose[of 1] re_im_decompose[of 𝗂] by simp_all
  thus ?thesis by (simp add: complex_eq_iff)
qed

lemma cnj_ivl: "cnj (ω (involution A)) = ω (A)" if "A  S"
  using involution_conjugate that by simp

text ‹
  Any such functional can be used to define a sesquilinear form that acts as a generalised inner
  product. This interpretation is justified below by providing a Cauchy-Schwarz inequality.
› (* TODO define/instantiate a locale for sesquilinear? *)
definition functional_inner :: "'a  'a  complex" ("_|_" 76)
  where "functional_inner A B  ω ((A)  B)"

named_theorems finner_simps

(* TODO good for simp? better to have geq_real_def and ‹ω (A ⦁ involution A) ≥R 0› as simp rules instead? *)
lemma finner_nonneg [finner_simps]:
  assumes "A  S"
  shows "A|A  0"
  using nonneg by (simp add: assms functional_inner_def)

lemma finner_scale [finner_simps]:
    "c *C A|B = (cnj c) * A|B"
    "A|c *C B = c * A|B"
  if "AS" "BS" for c and A B
  unfolding functional_inner_def
  subgoal using involution_mem that scale ivl_scale linearL'(1) multiplicative.composition_closed by presburger
  subgoal using involution_mem that multiplicative.composition_closed scalar_compat'(2) scale by presburger
  done

lemma finner_plus [finner_simps]: "A+B|C = A|C + B|C" "A|B+C = A|B + A|C"
  if "AS" "BS" "CS" for A B C
  unfolding functional_inner_def
  subgoal using involution_mem that add amult_closed distR ivl_ring by presburger
  subgoal using involution_mem that add amult_closed distL by presburger
  done

lemma finner_uminus [finner_simps]: "uminus A|B = uminus (A|B)" "A|uminus B = uminus (A|B)"
      if "AS" "BS" for c and A B
  using ivl_uminus mapsto_uminus by (simp_all add: that functional_inner_def)

lemma finner_minus [finner_simps]: "A-B|C = A|C - B|C" "A|B-C = A|B - A|C"
  if "AS" "BS" "CS" for c and A B C
  subgoal using finner_plus[OF _ m1.mem_uminus] finner_uminus(1) that by force
  subgoal using finner_plus[OF _ _ m1.mem_uminus] finner_uminus(2) that by force
  done

lemma finner_cnj:"A|B = cnj (B|A)"
  if "AS" "BS" for A B
  unfolding functional_inner_def
  using involution_conjugate[of "involution A  B"] antiautomorphism[of "involution A" B] involution[OF that(1)]
  by (simp add: that)

lemma finner_real_commute:
  assumes "AS" "BS" "A|B  "
  shows "A|B = B|A"
  using cnj_ivl[of "involution B  A"] antiautomorphism[of "involution B" A] involution[of B] assms(3)[unfolded Reals_cnj_iff]
  by (simp add: assms(1,2) functional_inner_def)

lemma finner_zero_commute:
  assumes "AS" "BS" "A|B = 0"
  shows "B|A = 0"
  using finner_real_commute assms Reals_0 by metis

lemma finner_self_0_if: "A|A = 0" if "A = 0"
  by (simp add: functional_inner_def mapsto_zero that)

lemma pythagorean_theorem:
  assumes "AS" "BS" "A|B = 0"
  shows "A+B|A+B = A|A + B|B"
proof (unfold functional_inner_def)
  have inS: "involution A  S" "involution B  S" "involution A  B  S" "involution B  A  S"
    by (simp_all add: assms)
  have BA_0: "ω (involution B  A) = 0"
    using involution antiautomorphism complex_cnj_zero cnj_ivl[symmetric]
    by (simp only: assms(1,2,3)[unfolded functional_inner_def] inS)
  have "ω ((involution (A + B))  (A + B)) = ω ((involution A  A) + involution A  B + involution B  A + involution B  B)"
    by (simp add: add.commute add.left_commute assms(1,2) distributive inS(1,2) ivl_ring)
  thus "ω (involution (A + B)  (A + B)) = ω (involution A  A) + ω (involution B  B)"
    using add BA_0 finner_zero_commute[OF assms]
    using assms(1,2,3) functional_inner_def by fastforce
qed

lemma finner_csqrt_nonneg: "csqrt (X|X)  0" if "XS"
  unfolding less_eq_complex_def
  using finner_nonneg Re_csqrt apply simp
  using cmod_Re that by blast+

lemma finner_cmod_eq: " B|B = B|B" if "BS"
  using cmod_Re finner_nonneg nonnegative_complex_is_real of_real_Re that by presburger

definition functional_norm :: "'a  real" ("_ω")
  where "functional_norm X  Re (csqrt (X|X))"

lemma fnorm_finner_squared: "B|B = Bω2" "B|B = Bω2" if "BS"
  unfolding functional_norm_def
  apply (metis Re_power_real complex_is_Real_iff complex_is_real_iff_compare0 finner_csqrt_nonneg functional_inner_def nonneg'(4) of_real_Re power2_csqrt that)
  by (metis cmod_Re finner_csqrt_nonneg norm_power power2_csqrt that)

lemma fnorm_nonneg: "Xω  0"
  using Re_csqrt functional_norm_def by presburger

lemma finner_lindep:
  fixes c::complex
  assumes "BS"
  shows "c *C B|B = c * Bω2"
    using finner_scale(1)[OF assms assms] fnorm_finner_squared(2)[OF assms]
    by (simp add: norm_mult)

lemma fnorm_scale: "c *C Xω = c * Xω" if "XS" for c::complex
proof (unfold functional_norm_def)
  have 2: "c *C X|c *C X = c * cnj c * X|X"
    using finner_scale(1) finner_scale(2)[OF m1.mem_scale] by (simp add: that)
  have "c *C X|c *C X = Re (c *C X|c *C X)" "X|X = Re (X|X)"
    using cmod_Re finner_nonneg(1)
    by (simp add: functional_inner_def less_eq_complexI m1.mem_scale nonneg'(3) that
        del: involution_mem)+
  thus "Re (csqrt (c *C X|c *C X)) = c * Re (csqrt (X|X))"
    apply simp
    using 2 cmod_Re complex_mod_sqrt_Re_mult_cnj real_sqrt_mult
    by (metis (no_types, lifting) cnj_x_x_geq0 mult.commute norm_mult)
qed

lemma finner_lindep_cong:
  assumes "BS" "A = c *C B"
  shows "A|B = Aω * Bω"
  using finner_lindep fnorm_scale
  by (simp add: assms power2_eq_square)


context ― ‹Controlling notation for partitions/division.› begin
no_notation equivalence.Partition (infixl '/ 75)

― ‹Stolen from Polygonal_Number_Theorem.Polygonal_Number_Theorem_Lemmas.qua_disc›
  on the AFP. The import brought in too many dependencies to be worth it.›
lemma qua_disc:
  fixes a b c :: real
  assumes "a>0"
  assumes "x::real. a*x^2+b*x + c  0"
  shows "b^2 - 4 * a * c  0"
proof -
  from assms have 0:"x::real. (a*x^2 + b*x + c)/a 0" by simp
  from assms have 1:"x::real.(b*x + c)/a = b/a*x + c/a" by (simp add: add_divide_distrib)
  from assms have "x::real.(a*x^2 + b*x + c)/a = x^2 + (b*x + c)/a"
    by (simp add: add_divide_eq_if_simps(1))
  from 1 this have "x::real.(a*x^2 + b*x  +  c)/a = x^2 + b/a*x + c/a" by simp
  hence atleastzero:"x::real. x^2 + b/a*x + c/a 0" using 0 by simp

  from assms have 2:"x::real. x^2 + b/a*x + c/a = x^2 + 2*b/(2*a)*x + c/a + b^2/(4*a^2)-b^2/(4*a^2)" by simp
  have simp1:"x::real.(x + b/(2*a))^2 = x^2 + 2*b/(2*a)*x + (b/(2*a))^2" by (simp add: power2_sum)
  have "(b/(2*a))^2 = b^2/(4*a^2)" by (metis four_x_squared power_divide)
  hence "x::real. x^2 + b/a*x + c/a = (x + b/(2*a))^2 + c/a-b^2/(4*a^2)" using 2 simp1 by auto
  hence "x::real. (x + b/(2*a))^2 + c/a-b^2/(4*a^2) 0" using atleastzero by presburger
  hence 3:"x::real. b^2/(4*a^2)-c/a(x + b/(2*a))^2" by (smt (verit, del_insts))
  have "x::real. (x + b/(2*a))^2=0" by (metis diff_add_cancel power_zero_numeral)
  hence "b^2/(4*a^2)-c/a0" using 3 by metis
  hence 4:"4*a^2*(b^2/(4*a^2)-c/a)0" using assms by (simp add: mult_nonneg_nonpos)
  have 5:"4*a^2*b^2/(4*a^2) = b^2" using assms by simp
  have 6:"4*a^2 * c/a = 4*a * c" using assms by (simp add: power2_eq_square)
  show ?thesis using 4 5 6 assms by (simp add: Rings.ring_distribs(4))
qed

lemma sign_of_discriminant:
  fixes a b c :: real
  assumes "x::real. a*x^2 + b*x + c 0"
  shows "a  0  b^2 - 4 * a * c  0" "a < 0  b^2 - 4 * a * c  0"
  subgoal apply (cases "a=0")
    subgoal by (metis Groups.add_ac(2) assms diff_add_cancel diff_zero mult_zero_left mult_zero_right
      nonzero_mult_div_cancel_left real_sqrt_pow2 sum_power2_le_zero_iff times_divide_eq_right zero_eq_power2)
    subgoal using qua_disc assms by simp
    done
  subgoal using assms by (smt (verit, ccfv_threshold) zero_compare_simps(8,12))
  done

end


lemma cauchy_schwarz_square:
  assumes "AS" "BS"
  shows "¦A|B¦2  A|A * B|B"
proof -
  consider (some_zero) "A=0  B=0" | (nonzero) "A0  B0" by fastforce
  then show ?thesis
  proof (cases)
    case some_zero
    then show ?thesis
      using finner_plus(1) finner_zero_commute
      by (metis assms cnj_x_x cnj_x_x_geq0 eq_add_iff mult_eq_0_iff)
  next
    case nonzero ― ‹Mostly revolves around the discriminant of a quadratic,
        and the inequality @{thm qua_disc} (cribbed from Polygonal_Number_Theorem›).›

    let ?c = "¦B|A¦ / B|A"
    have c_witness: "?c = 1" "?c * B|A = ¦B|A¦" if "B|A  0"
      using Real_Vector_Spaces.norm_divide[of "B|A" "B|A"] that
      by (simp_all add: abs_complex_def)
    have "c::complex. cmod c = 1  c * B|A = ¦B|A¦"
      apply (cases "B|A=0")
      subgoal using norm_one by fastforce
      using c_witness by blast
    then
    obtain c :: complex
      where c: "cmod c = 1" "c * B|A = ¦B|A¦"
      by blast
    { fix x :: complex assume x: "x"
      have "(x * c) *C A + B|(x * c) *C A + B =
          (x * c) *C A|(x * c) *C A +
          (x * c) *C A|B + B|(x * c) *C A + B|B"
        using m1.mem_scale finner_plus by (simp add: assms finner_plus(1))+
      also have " = (cmod (x * c))2 * A|A + (x * c) *C A|B + B|(x * c) *C A + B|B"
        apply (simp add: complex_mod_mult_cnj del: Real_Vector_Spaces.of_real_power)
        using finner_scale[OF assms(1), of _ "x * c"] m1.mem_scale[OF assms(2)]
        using assms(1) complex_norm_square m1.mem_scale by auto
      also have " = (cmod (x * c))2 * A|A + cnj (x * c) * A|B + (x * c) * B|A + B|B"
        using finner_scale m1.mem_scale assms by simp
      also have " = x * c2 * A|A +
          cnj (x * c * B|A) + ((x * c) * B|A) + B|B"
        by (metis assms complex_cnj_mult finner_cnj)
      also have " = ¦x * c¦2 * A|A + cnj (x*¦B|A¦) + (x*¦B|A¦) + B|B"
        apply (simp add: complex_of_real_cmod)
        using c(2) by (metis Extra_Ordered_Fields.sign_simps(4) complex_cnj_mult)
      also have " = A|A * x2 + (2*B|A)*x + B|B"
        unfolding fnorm_finner_squared(2)[OF assms(1)] fnorm_finner_squared(2)[OF assms(2)]
        apply (simp add: complex_of_real_cmod)
        using c(1) Reals_cnj_iff x assms abs_complex_real complex_norm_square complex_of_real_cmod
          fnorm_finner_squared(1) norm_mult norm_one
        by (smt (verit) sign_simps(3,5) more_arith_simps(6) of_real_power power2_eq_square)
      finally
      have "Aω2 * x2 + (2*B|A)*x + Bω2  0"
        unfolding fnorm_finner_squared(2)[OF assms(1)] fnorm_finner_squared(2)[OF assms(2)]
        by (metis assms finner_nonneg m1.mem_add m1.mem_scale) }
    note quadratic_nonnegative = this
    have "0  A|A * x2 + 2 * B|A * x + B|B" for x::real
      using quadratic_nonnegative[of x, simplified]
      unfolding functional_norm_def
      using assms(1,2) fnorm_finner_squared(1) quadratic_nonnegative
      by (smt (verit, ccfv_threshold) Re_complex_of_real Reals_of_real cmod_Re finner_nonneg less_eq_complex_def
          of_real_0 of_real_mult of_real_power plus_complex.sel(1))
    hence "(2*B|A)2 - 4*A|A*B|B  0"
      using sign_of_discriminant(1) zero_le_power norm_ge_zero
      by blast
    then show ?thesis
      apply (simp add: abs_complex_def)
      apply (subst of_real_power[of "A|B" 2, symmetric])
      using norm_of_real of_real_0 of_real_mult
      by (smt (verit, del_insts) Im_complex_of_real Re_complex_of_real assms(1,2) cnj_x_x complex_norm_square
          finner_cnj finner_nonneg fnorm_finner_squared(1) less_eq_complex_def
          x_cnj_x)
  qed
qed

lemma cauchy_schwarz:
  assumes "AS" "BS"
  shows "A|B  Aω * Bω"
proof -
  from cauchy_schwarz_square[OF assms]
  have "A|B2  Aω2 * Bω2" (* . ChatGPT fails *)
    (* by (smt (verit, ccfv_SIG) Re_complex_of_real assms complex_of_real_cmod fnorm_finner_squared(1)
        less_eq_complex_def of_real_mult of_real_power) (* sledgehammer succeeds *) *)
    unfolding abs_complex_def by (simp add: assms fnorm_finner_squared(1) less_eq_complex_def)
  hence "A|B  sqrt (Aω2 * Bω2)"
    (* by (simp add: real_le_lsqrt) ChatGPT fails *)
    using real_le_rsqrt by blast (* sledgehammer succeeds *)
  also have "sqrt (Aω2 * Bω2) = Aω * Bω"
    (* by (simp add: real_sqrt_mult) ChatGPT fails *)
    by (simp add: fnorm_nonneg real_sqrt_mult) (* sledgehammer succeeds *)
  finally show ?thesis .
qed


subsection ‹Identities for states on unital $C^*$-algebras›
text‹For now, see \cite[page 49, Prop.~2.3.11]{bratteli1979}.
  We already have @{thm involution_conjugate}.›

lemma state_norm_leq_inner: "ω A2  A|A" if "AS"
  using cauchy_schwarz_square[OF that, of 𝟭]
  unfolding functional_inner_def
  by (metis amult_id(3) antiautomorphism cnj_ivl cnj_x_x complex_norm_square involution_conjugate
      local.one more_arith_simps(6) multiplicative.unit_closed that unit_self_adjoint)

lemma state_zero_if_inner_zero: "ω A = 0" if "ω (involution A  A) = 0" "AS"
proof-
  have "(norm (ω A))2 = 0"
    using state_norm_leq_inner apply (simp add: functional_inner_def)
    by (metis complex_of_real_mono_iff norm_le_zero_iff
        norm_power of_real_eq_0_iff of_real_power that zero_eq_power2)
  thus ?thesis by simp
qed

end (* positive_normalised_linear_functional *)


locale Cstar_state =
    Cstar_algebra F S scale multiplication vector_norm unit involution +
    positive_normalised_linear_functional S scale multiplication unit involution ω
  for F :: "complex set"
    and S :: "'a::ab_group_add set"
    and scale :: "complex  'a  'a"  (infixr *C 75)
    and multiplication :: "'a  'a  'a"  (infixr  74)
    and vector_norm :: "'a  real"  (_ [65])
    and unit :: "'a" (𝟭)
    and involution :: "'a'a" ("_" [99] 100)
    and ω :: "'acomplex"
begin

(* TODO name *)
lemma mult_inner_norm_bound:
  assumes "A B. AS; BS  B  A|B  A  B2 * ω (A  A)"
    ― ‹This assumption is, in fact, a theorem. It can be proven using spectral theory,
    by defining positive operators to enable the following ordering relation:
    $$A^\dagger B^\dagger B A \leq \|B\|^2 A^\dagger A$$
    See Bratteli and Robinson's textbook, p.~51 for proof of the lemma,
    and p.~36 for ordering on positive operators \cite{bratteli1979}.
    The definition of an operator as positive depends on the operator's spectrum
    (i.e.~it is in the positive half-line, p.~32).
    Spectral theory is, for now, out of scope for this development.›
    and "AS" "BS"
  shows "¦B  A|A¦  A|A * B"
proof-
  have "¦B  A|A¦2  B  A|B  A * A|A"
    using cauchy_schwarz_square[of BA A]
    by (auto simp: assms(2,3))
  also have "  (B2) * ω (involution A  A) * A|A"
    using assms(1)[OF assms(2,3)] finner_nonneg[OF assms(2)] mult_right_mono by blast
  finally have "¦B  A|A¦2  A|A * (B2) * A|A"
    by (metis Extra_Ordered_Fields.sign_simps(5) functional_inner_def)
  then have "¦B  A|A¦2  (A|A * B)2"
    by (smt (verit) of_real_power ordered_field_class.sign_simps(23,4,5) power2_eq_square)
  moreover have "¦0¦  ¦B  A|A¦" by (simp add: abs_nn)
  ultimately have "B  A|A  Re(A|A) * B"
    apply (intro power2_le_imp_le[of "B  A|A" "Re (A|A) * B"])
    subgoal using finner_cmod_eq x_cnj_x
      by (smt (verit, best) Re_complex_of_real complex_norm_square
          less_eq_complex_def of_real_mult of_real_power assms(2))
    subgoal by (simp add: assms(2,3) functional_inner_def nonneg'(1))
    done
  thus ?thesis
    by (metis Re_complex_of_real Reals_cnj_iff assms(2) of_real_mult
        complex_cnj_complex_of_real complex_is_Real_iff
        complex_of_real_cmod finner_cmod_eq less_eq_complexI)
qed

end (* Cstar_state *)


subsection ‹Morphisms›

locale involutive_complex_algebras =
  A1: involutive_complex_algebra S1 scale1 multiplication1 unit1 involution1 +
  A2: involutive_complex_algebra S2 scale2 multiplication2 unit2 involution2
  for S1 :: "'a::ab_group_add set"
    and scale1 :: "complex  'a  'a"  (infixr *C1 75)
    and multiplication1 :: "'a  'a  'a"  (infixr 1 74)
    and unit1 :: "'a" (𝟭1)
    and involution1 :: "'a'a"
    and S2 :: "'b::ab_group_add set"
    and scale2 :: "complex  'b  'b"  (infixr *C2 75)
    and multiplication2 :: "'b  'b  'b"  (infixr 2 74)
    and unit2 :: "'b" (𝟭2)
    and involution2 :: "'b'b"


text ‹We define *-homomorphisms to be unital always. I believe a minority
  of authors consider non-unital homomorphisms of rings, but then you need
  to consider degenerate cases (e.g. termλx. 0). For some discussion, see e.g.
  \href{mathoverflow}{
    https://mathoverflow.net/questions/34332/consequences-of-not-requiring-ring-homomorphisms-to-be-unital
  }.›
locale involutive_complex_homomorphism = involutive_complex_algebras +
  fixes f :: "'a'b"
  assumes f_codomain: "f`S1  S2"
    and f_unit: "f 𝟭1 = 𝟭2"
    and f_scale: "r x. xS1  f (r *C1 x) = r *C2 (f x)"
    and f_plus: "x y. xS1; yS1  f (x + y) = (f x) + (f y)"
    and f_multiplication: "x y. xS1; yS1 
      f (x 1 y) = (f x) 2 (f y)"
    and f_involution: "x. xS1 
      f (involution1 x) = involution2 (f x)"
begin

lemma linear_f: "linear_on S1 S2 scale1 scale2 f"
  apply unfold_locales
  using f_plus f_scale by auto

interpretation linear_f: linear_on S1 S2 scale1 scale2 f
  using linear_f .

end (* involutive_complex_homomorphism *)

abbreviation (in involutive_complex_algebras) homomorphism
  where "homomorphism f  involutive_complex_homomorphism
    S1 scale1 multiplication1 unit1 involution1
    S2 scale2 multiplication2 unit2 involution2
    f"

locale involutive_complex_isomorphism = involutive_complex_homomorphism +
  assumes bij_f: "bij_betw f S1 S2"

abbreviation (in involutive_complex_algebras) isomorphism
  where "isomorphism f  involutive_complex_isomorphism
    S1 scale1 multiplication1 unit1 involution1
    S2 scale2 multiplication2 unit2 involution2
    f"

locale involutive_complex_automorphism =
    involutive_complex_isomorphism S scale multiplication unit involution
                                   S scale multiplication unit involution f
  for S scale multiplication unit involution f

abbreviation (in involutive_complex_algebra) automorphism
  where "automorphism f  involutive_complex_automorphism S scale multiplication unit involution f"




locale Cstar_algebras =
  A1: Cstar_algebra F1 S1 scale1 multiplication1 vnorm1 unit1 involution1 +
  A2: Cstar_algebra F2 S2 scale2 multiplication2 vnorm2 unit2 involution2
  for F1 :: "complex set"
    and S1 :: "'a::ab_group_add set"
    and scale1 :: "complex  'a  'a"  (infixr *C1 75)
    and multiplication1 :: "'a  'a  'a"  (infixr 1 74)
    and vnorm1 :: "'a  real"  (_1 [65])
    and unit1 :: "'a" (𝟭1)
    and involution1 :: "'a'a"
    and F2 :: "complex set"
    and S2 :: "'b::ab_group_add set"
    and scale2 :: "complex  'b  'b"  (infixr *C2 75)
    and multiplication2 :: "'b  'b  'b"  (infixr 2 74)
    and vnorm2 :: "'b  real"  (_2 [65])
    and unit2 :: "'b" (𝟭2)
    and involution2 :: "'b'b"
begin

sublocale involutive_complex_algebras
  by unfold_locales

end

text ‹A $C^*$-homomorphism is a homomorphism of $\phantom{}^*$-algebras between $C^*$-algebras.›
locale Cstar_homomorphism = Cstar_algebras + involutive_complex_homomorphism


lemma (in Cstar_algebras) homomorphismI:
  assumes "homomorphism f"
  shows "Cstar_homomorphism F1 S1 scale1 multiplication1 vnorm1 unit1 involution1
                            F2 S2 scale2 multiplication2 vnorm2 unit2 involution2 f"
  by (simp add: assms Cstar_algebras_axioms Cstar_homomorphism.intro)


locale Cstar_isomorphism = Cstar_algebras + involutive_complex_isomorphism


locale Cstar_automorphism =
    Cstar_isomorphism F V scale multiplication vector_norm unit involution
                       F V scale multiplication vector_norm unit involution f
  for F :: "complex set"
    and V :: "'v::ab_group_add set"
    and scale :: "complex  'v  'v"  (infixr *C 75)
    and multiplication :: "'v  'v  'v"  (infixr  74)
    and vector_norm :: "'v  real"  (_ [65])
    and unit :: "'v" (𝟭)
    and involution :: "'v'v" (‹_ 73)
    and f
begin

lemma is_star_aut: "involutive_complex_automorphism V (*C) (⦁) 𝟭 involution f"
  using involutive_complex_isomorphism_axioms by (simp only: involutive_complex_automorphism_def)

sublocale as_star_aut: involutive_complex_automorphism V
  using is_star_aut .

end


lemma (in Cstar_algebra) automorphismI:
  assumes "automorphism f"
  shows "Cstar_automorphism F V scale multiplication vector_norm unit involution f"
  using involutive_complex_isomorphism.axioms[OF assms[unfolded involutive_complex_automorphism_def]]
  unfolding involutive_complex_isomorphism_axioms_def
  unfolding involutive_complex_homomorphism_def involutive_complex_homomorphism_axioms_def
  by unfold_locales presburger+

end