theory ScottVariantClassroom imports Main  (*C. Benzmüller, 2022*)
begin

(**********************************************)
(*** Higher-Order Modal Logic (HOML) in HOL ***)
(**********************************************)

(*unimportant*) declare [[smt_solver=cvc4,smt_oracle]]
(*unimportant*) declare[[syntax_ambiguity_warning=false]]
(*unimportant*) nitpick_params[user_axioms,card=2]
(*Type declarations and type abbreviations*)
typedecl i (*Possible worlds*)
typedecl e (*Individuals*)
type_synonym \<sigma> = "i\<Rightarrow>bool" (*World-lifted propositions*)
type_synonym \<gamma> = "e\<Rightarrow>\<sigma>" (*Lifted predicates*)
type_synonym \<mu> = "\<sigma>\<Rightarrow>\<sigma>" (*Unary modal connectives*)
type_synonym \<nu> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (*Binary modal connectives*)

(*Modal logic connectives (operating on truth-sets)*)
abbreviation c1::\<sigma> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation c2::\<sigma> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation c3::\<mu> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w.\<not>(\<phi> w)"
abbreviation c4::\<nu> (infix"\<^bold>\<and>"50) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<and>(\<psi> w)"
abbreviation c5::\<nu> (infix"\<^bold>\<or>"49) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<or>(\<psi> w)"
abbreviation c6::\<nu> (infix"\<^bold>\<rightarrow>"48) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation c7::\<nu> (infix"\<^bold>\<leftrightarrow>"47) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longleftrightarrow>(\<psi> w)"
consts R::"i\<Rightarrow>i\<Rightarrow>bool" ("_\<^bold>r_")  (*Accessibility relation*)
abbreviation c8::\<mu> ("\<^bold>\<box>_"[54]55) where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v.(w\<^bold>rv)\<longrightarrow>(\<phi> v)"
abbreviation c9::\<mu> ("\<^bold>\<diamond>_"[54]55) where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v.(w\<^bold>rv)\<and>(\<phi> v)"
abbreviation c10::"\<gamma>\<Rightarrow>\<gamma>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<Phi> \<equiv> \<lambda>x.\<lambda>w.\<not>(\<Phi> x w)"
abbreviation c11::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>=_") where "x\<^bold>=y \<equiv> \<lambda>w.(x=y)"
abbreviation c12::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>\<noteq>_") where "x\<^bold>\<noteq>y \<equiv> \<lambda>w.(x\<noteq>y)"

(*Polymorphic possibilist quantification*)
abbreviation q1::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x.(\<Phi> x w)"
abbreviation q2 (binder"\<^bold>\<forall>"[10]11) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation q3::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x.(\<Phi> x w)"
abbreviation q4 (binder"\<^bold>\<exists>"[10]11) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

(*Actualist quantification for individuals*)
consts existsAt::\<gamma> ("_\<^bold>@_")
abbreviation q5::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<forall>\<^sup>E") where "\<^bold>\<forall>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<forall>x.(x\<^bold>@w)\<longrightarrow>(\<Phi> x w)"
abbreviation q6 (binder"\<^bold>\<forall>\<^sup>E"[8]9) where "\<^bold>\<forall>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<forall>\<^sup>E\<phi>"
abbreviation q7::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<exists>\<^sup>E") where "\<^bold>\<exists>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<exists>x.(x\<^bold>@w)\<and>(\<Phi> x w)"
abbreviation q8 (binder"\<^bold>\<exists>\<^sup>E"[8]9) where "\<^bold>\<exists>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<exists>\<^sup>E\<phi>"

(*Meta-logical predicate for global validity*)
abbreviation g1::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w. \<psi> w"

(******************************************************)
(*** Gödel's Ontological Argument (Scott's Variant) ***)
(******************************************************)

(*Positive properties*)
consts posProp::"\<gamma>\<Rightarrow>\<sigma>" ("\<P>")

(*Definition of God-like: x is God-like if, and only if, it
  possesses all positive properties*)
definition G ("\<G>") where "\<G>(x) \<equiv> \<^bold>\<forall>\<Phi>.(\<P>(\<Phi>) \<^bold>\<rightarrow> \<Phi>(x))"

(*Definition of Essence: Property \<Phi> is an essence of x if, and only if,
 \<Phi> holds for x and \<Phi> necessarily entails every property Z of x*)
definition Ess ("_Ess._"[80,80]81)
  where "\<Phi> Ess. x \<equiv> \<Phi>(x) \<^bold>\<and> (\<^bold>\<forall>\<Psi>. \<Psi>(x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>y. \<Phi>(y) \<^bold>\<rightarrow> \<Psi>(y)))"

(*Definition of Necessary Existence: x has the property of necessary
  existence if, and only if, the essence of x is necessarily instantiated*)
definition NE ("\<N>\<E>") where "\<N>\<E>(x) \<equiv> \<^bold>\<forall>\<Phi>. \<Phi> Ess. x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>x. (\<Phi>(x)))"

(*Axioms of Scott's variant*)
axiomatization where
 (*one of a property or its complement∁is positive*)
 AXIOM1: "\<lfloor>\<^bold>\<forall>\<Phi>. \<P>(\<^bold>\<not>\<Phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>\<P>(\<Phi>)\<rfloor>" and
 (*a property necessarily entailed by a positive property is positive*)
 AXIOM2: "\<lfloor>\<^bold>\<forall>\<Phi> \<Psi>.  \<^bold>\<box>(\<^bold>\<forall>x. \<Phi>(x) \<^bold>\<rightarrow> \<Psi>(x)) \<^bold>\<rightarrow> \<P>(\<Psi>)\<rfloor>" and
 (*\<P> is a logical property and \<G> is is definitely logical as an intersection
   of positive properties; any such property ought to be positive*)
 AXIOM3: "\<lfloor>\<P>(\<G>)\<rfloor>" and
 (*any positive property is necessarily positive*)
 AXIOM4: "\<lfloor>\<^bold>\<forall>\<Phi>. \<P>(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<P>(\<Phi>)\<rfloor>" and
 (*necessary existence is a positive property*)
 AXIOM5: "\<lfloor>\<P>(\<N>\<E>)\<rfloor>"

(*Consistency*)
lemma True nitpick[satisfy,show_all,format=2,card=2] oops (*Model found*)
lemma False sledgehammer[verbose,overlord] nitpick oops

(*We only need the B axiom*)
axiomatization where B:  "\<lfloor>\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<Phi>\<rfloor>"
 (*Logic KB: what holds is necessarily possible*)
lemma B': "\<forall>x y. \<not>x\<^bold>ry \<or> y\<^bold>rx" using B by fastforce

(*Consistency*)
lemma True nitpick[satisfy,show_all,format=2,card=1] oops (*Model found*)
lemma False sledgehammer nitpick oops

(*Verifying Scott's proof from*)
 (*positive properties are possibly exemplified*)
theorem THEOREM1: "\<lfloor>\<^bold>\<forall>\<Phi>. \<P>(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>x. \<Phi>(x))\<rfloor>"
  using AXIOM1 AXIOM2 by blast
 (*possibly there exists a Godlike entity*)
theorem CORO: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>x. \<G>(x))\<rfloor>" using THEOREM1 AXIOM3 by simp
 (*being Godlike is an essential property of any Godlike entity*)
theorem THEOREM2: "\<lfloor>\<^bold>\<forall>x. \<G>(x) \<^bold>\<rightarrow> \<G> Ess. x\<rfloor>" sledgehammer
  by (smt (verit) AXIOM1 AXIOM4 Ess_def G_def)
 (*necessarily there exists a Godlike entity*)
theorem THEOREM3: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>x. \<G>(x))\<rfloor>"
  by (metis AXIOM5 B' CORO G_def NE_def THEOREM2)
 (*there exists a Godlike entity*)
theorem THEOREM4: "\<lfloor>\<^bold>\<exists>x. \<G>(x)\<rfloor>" using B' CORO THEOREM3 by blast

 (*self-difference is not a positive property*)
lemma C1: "\<lfloor>\<^bold>\<not>\<P>(\<lambda>x. x\<^bold>\<noteq>x)\<rfloor>" using AXIOM1 AXIOM2 by blast
 (*absurdum/falsum is not a positive property*)
lemma C1': "\<lfloor>\<^bold>\<not>\<P>(\<lambda>x. \<^bold>\<bottom>)\<rfloor>" using AXIOM1 AXIOM2 by blast
 (*a property necessarily entailed by a positive property is positive*)
lemma C2: "\<lfloor>\<^bold>\<forall>\<Phi> \<Psi>. \<P>(\<Phi>) \<^bold>\<and> (\<^bold>\<forall>x. \<Phi>(x) \<^bold>\<rightarrow> \<Psi>(x)) \<^bold>\<rightarrow> \<P>(\<Psi>)\<rfloor>"
   by (metis AXIOM1 G_def THEOREM4)

(*Consistency*)
lemma True nitpick[satisfy,show_all,format=2] oops (*Model found*)
lemma False sledgehammer nitpick oops

(*Further Corollaries of Scott's theory*)
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>\<rfloor>" (*Modal collapse: holds*)
  sledgehammer nitpick
  oops

(*Further Corollaries of Scott's theory*)
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>\<rfloor>" (*Modal collapse: holds*)
proof - {fix w fix Q
 have 1: "\<forall>x. \<G>(x)(w) \<longrightarrow> (\<^bold>\<forall>Z. Z(x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>z. \<G>(z) \<^bold>\<rightarrow> Z(z)))(w)"
         by (metis AXIOM1 AXIOM4 G_def)
 have 2: "(\<exists>x. \<G>(x)(w)) \<longrightarrow> (Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>z. (\<G> z) \<^bold>\<rightarrow> Q))(w)"
         using 1 by force
 have 3: "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q)(w)" using B' THEOREM3 2 by blast}
 thus ?thesis by auto qed

end


section \<open>Bounded Linear Operator\<close>
theory Bounded_Linear_Operator
imports
  "HOL-Analysis.Analysis"
begin

typedef (overloaded) 'a blinop = "UNIV::('a, 'a) blinfun set"
by simp

setup_lifting type_definition_blinop

lift_definition blinop_apply::"('a::real_normed_vector) blinop \<Rightarrow> 'a \<Rightarrow> 'a" is blinfun_apply .
lift_definition Blinop::"('a::real_normed_vector \<Rightarrow> 'a) \<Rightarrow> 'a blinop" is Blinfun .

no_notation vec_nth (infixl "$" 90)
notation blinop_apply (infixl "$" 999)
declare [[coercion "blinop_apply :: ('a::real_normed_vector) blinop \<Rightarrow> 'a \<Rightarrow> 'a"]]

instantiation blinop :: (real_normed_vector) real_normed_vector
begin

lift_definition norm_blinop :: "'a blinop \<Rightarrow> real" is norm .

lift_definition minus_blinop :: "'a blinop \<Rightarrow> 'a blinop \<Rightarrow> 'a blinop" is minus .

lift_definition dist_blinop :: "'a blinop \<Rightarrow> 'a blinop \<Rightarrow> real" is dist .

definition uniformity_blinop :: "('a blinop \<times> 'a blinop) filter" where
  "uniformity_blinop = (INF e\<in>{0<..}. principal {(x, y). dist x y < e})"

definition open_blinop :: "'a blinop set \<Rightarrow> bool" where
  "open_blinop U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"

lift_definition uminus_blinop :: "'a blinop \<Rightarrow> 'a blinop" is uminus .

lift_definition zero_blinop :: "'a blinop" is 0 .

lift_definition plus_blinop :: "'a blinop \<Rightarrow> 'a blinop \<Rightarrow> 'a blinop" is plus .

lift_definition scaleR_blinop::"real \<Rightarrow> 'a blinop \<Rightarrow> 'a blinop" is scaleR .

lift_definition sgn_blinop :: "'a blinop \<Rightarrow> 'a blinop" is sgn .

instance
  apply standard
  apply (transfer', simp add: algebra_simps sgn_div_norm open_uniformity norm_triangle_le
    uniformity_blinop_def dist_norm
    open_blinop_def)+
  done
end

lemma bounded_bilinear_blinop_apply: "bounded_bilinear ($)"
  unfolding bounded_bilinear_def
  by transfer (simp add: blinfun.bilinear_simps blinfun.bounded)

interpretation blinop: bounded_bilinear "($)"
  by (rule bounded_bilinear_blinop_apply)

lemma blinop_eqI: "(\<And>i. x $ i = y $ i) \<Longrightarrow> x = y"
  by transfer (rule blinfun_eqI)

lemmas bounded_linear_apply_blinop[intro, simp] = blinop.bounded_linear_left
declare blinop.tendsto[tendsto_intros]
declare blinop.FDERIV[derivative_intros]
declare blinop.continuous[continuous_intros]
declare blinop.continuous_on[continuous_intros]

instance blinop :: (banach) banach
  apply standard
  unfolding convergent_def LIMSEQ_def Cauchy_def
  apply transfer
  unfolding convergent_def[symmetric] LIMSEQ_def[symmetric] Cauchy_def[symmetric]
    Cauchy_convergent_iff
  .

instance blinop :: (euclidean_space) heine_borel
  apply standard
  unfolding LIMSEQ_def bounded_def
  apply transfer
  unfolding LIMSEQ_def[symmetric] bounded_def[symmetric]
  apply (rule bounded_imp_convergent_subsequence)
  .

instantiation blinop::("{real_normed_vector, perfect_space}") real_normed_algebra_1
begin

lift_definition one_blinop::"'a blinop" is id_blinfun .
lemma blinop_apply_one_blinop[simp]: "1 $ x = x"
  by transfer simp

lift_definition times_blinop :: "'a blinop \<Rightarrow> 'a blinop \<Rightarrow> 'a blinop" is blinfun_compose .

lemma blinop_apply_times_blinop[simp]: "(f * g) $ x = f $ (g $ x)"
  by transfer simp

instance
proof
  from not_open_singleton[of "0::'a"] have "{0::'a} \<noteq> UNIV" by force
  then obtain x :: 'a where "x \<noteq> 0" by auto
  show "0 \<noteq> (1::'a blinop)"
    apply transfer
    apply transfer
    apply (auto dest!: fun_cong[where x=x] simp: \<open>x \<noteq> 0\<close>)
    done
qed (transfer, transfer,
  simp add: o_def linear_simps onorm_compose onorm_id onorm_compose[simplified o_def])+
end

lemmas bounded_bilinear_bounded_uniform_limit_intros[uniform_limit_intros] =
  bounded_bilinear.bounded_uniform_limit[OF Bounded_Linear_Operator.bounded_bilinear_blinop_apply]
  bounded_bilinear.bounded_uniform_limit[OF Bounded_Linear_Function.bounded_bilinear_blinfun_apply]
  bounded_bilinear.bounded_uniform_limit[OF Bounded_Linear_Operator.blinop.flip]
  bounded_bilinear.bounded_uniform_limit[OF Bounded_Linear_Function.blinfun.flip]
  bounded_linear.uniform_limit[OF blinop.bounded_linear_right]
  bounded_linear.uniform_limit[OF blinop.bounded_linear_left]
  bounded_linear.uniform_limit[OF bounded_linear_apply_blinop]

no_notation
  blinop_apply (infixl "$" 999)
notation vec_nth (infixl "$" 90)

end


theory week02B_demo_s imports Main begin

section{* Propositional logic *}

subsection{* Basic rules *}

text{* \<and> *}
thm conjI

thm conjunct2
thm conjE

text{* \<or> *}
thm disjI1
thm disjI2
thm disjE

text{* \<longrightarrow> *}
thm impI impE

subsection{* Examples *}

text{* a simple backward step: *}
lemma "A \<and> B" thm conjI
apply(rule conjI)
oops

text{* a simple backward proof: *}
lemma "B \<and> A \<longrightarrow> A \<and> B"
apply (rule impI) thm impI
apply (erule conjE) thm conjI
apply (rule conjI)
 apply assumption
apply assumption
done

lemma "A \<or> B \<longrightarrow> B \<or> A"
apply (rule impI)
apply (erule disjE)
 apply (rule disjI2)
 apply assumption
apply (rule disjI1)
apply assumption
done

lemma "\<lbrakk> B \<longrightarrow> C; A \<longrightarrow> B \<rbrakk> \<Longrightarrow> A \<longrightarrow> C"
apply (rule impI)
apply (erule impE)
 apply (erule impE)
  apply assumption
 apply assumption
apply assumption
done

thm notI notE

lemma "\<not>A \<or> \<not>B \<Longrightarrow> \<not>(A \<and> B)"
apply (rule notI)
apply (erule disjE)
 apply (erule conjE)
 apply (erule notE)
 apply assumption
apply (erule conjE)
apply (erule notE)
apply assumption
done

text {* Case distinctions *}

lemma "P \<or> \<not>P"
  apply (case_tac "P")
  oops

thm FalseE

lemma "(\<not>P \<longrightarrow> False) \<longrightarrow> P"
apply (rule impI)
apply (case_tac P)
 apply assumption
apply (erule impE)
 apply assumption
apply (erule FalseE)
done

text{* Explicit backtracking: *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply(erule conjE)
back
apply(assumption)
done
text{* UGLY! EVIL! AVOID! *}

text{* Implicit backtracking: chaining with , *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply (erule conjE, assumption)
done

text{* OR: use rule_tac or erule_tac to instantiate the schematic variables of the rule *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply (erule_tac P=A and Q=B in conjE)
apply assumption
done

text {* more rules *}
text{* \<and> *}
thm conjunct1 conjunct2

text{* \<or> *}
thm disjCI

lemma our_own_disjCI: "(\<not>Q \<longrightarrow> P) \<Longrightarrow> P \<or> Q"
apply (case_tac Q)
 apply (rule disjI2)
 apply assumption
apply (erule impE)
 apply assumption
apply (rule disjI1)
apply assumption
done

text{* \<longrightarrow> *}
thm mp

text{* = (iff) *}
thm iffI iffE iffD1 iffD2

text{* Equality *}
thm refl sym trans

text{* \<not> *}
thm notI notE

text{* Contradictions *}
thm FalseE ccontr classical excluded_middle

-- {* more rules *}

text {* defer and prefer *}
lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
  prefer 2
  defer
  oops

text{* classical propositional logic: *}
lemma Pierce: "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
   apply (rule impI)
   apply (erule notE)
   apply assumption
  apply assumption
  done

text {* Exercises *}

lemma "A \<and> B \<longrightarrow> A \<longrightarrow> B"
  oops

lemma "A \<longrightarrow> (B \<or> C) \<longrightarrow> (\<not> A \<or> \<not> B) \<longrightarrow> C"
  oops

lemma"((A \<longrightarrow> B) \<and> (B \<longrightarrow> A)) = (A = B)"
  oops

lemma "(A \<longrightarrow> (B \<and> C)) \<longrightarrow> (A \<longrightarrow> C)"
  oops

end


(*  Title:       Liminf of Lazy Lists
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Maintainer:  Jasmin Blanchette <j.c.blanchette at vu.nl>
*)

section \<open>Liminf of Lazy Lists\<close>

theory Lazy_List_Liminf
  imports Coinductive.Coinductive_List
begin

text \<open>
Lazy lists, as defined in the \emph{Archive of Formal Proofs}, provide finite and infinite lists in
one type, defined coinductively. The present theory introduces the concept of the union of all
elements of a lazy list of sets and the limit of such a lazy list. The definitions are stated more
generally in terms of lattices. The basis for this theory is Section 4.1 (``Theorem Proving
Processes'') of Bachmair and Ganzinger's chapter.
\<close>

definition Sup_llist :: "'a set llist \<Rightarrow> 'a set" where
  "Sup_llist Xs = (\<Union>i \<in> {i. enat i < llength Xs}. lnth Xs i)"

lemma lnth_subset_Sup_llist: "enat i < llength xs \<Longrightarrow> lnth xs i \<subseteq> Sup_llist xs"
  unfolding Sup_llist_def by auto

lemma Sup_llist_LNil[simp]: "Sup_llist LNil = {}"
  unfolding Sup_llist_def by auto

lemma Sup_llist_LCons[simp]: "Sup_llist (LCons X Xs) = X \<union> Sup_llist Xs"
  unfolding Sup_llist_def
proof (intro subset_antisym subsetI)
  fix x
  assume "x \<in> (\<Union>i \<in> {i. enat i < llength (LCons X Xs)}. lnth (LCons X Xs) i)"
  then obtain i where len: "enat i < llength (LCons X Xs)" and nth: "x \<in> lnth (LCons X Xs) i"
    by blast
  from nth have "x \<in> X \<or> i > 0 \<and> x \<in> lnth Xs (i - 1)"
    by (metis lnth_LCons' neq0_conv)
  then have "x \<in> X \<or> (\<exists>i. enat i < llength Xs \<and> x \<in> lnth Xs i)"
    by (metis len Suc_pred' eSuc_enat iless_Suc_eq less_irrefl llength_LCons not_less order_trans)
  then show "x \<in> X \<union> (\<Union>i \<in> {i. enat i < llength Xs}. lnth Xs i)"
    by blast
qed ((auto)[], metis i0_lb lnth_0 zero_enat_def, metis Suc_ile_eq lnth_Suc_LCons)

lemma lhd_subset_Sup_llist: "\<not> lnull Xs \<Longrightarrow> lhd Xs \<subseteq> Sup_llist Xs"
  by (cases Xs) simp_all

definition Sup_upto_llist :: "'a set llist \<Rightarrow> nat \<Rightarrow> 'a set" where
  "Sup_upto_llist Xs j = (\<Union>i \<in> {i. enat i < llength Xs \<and> i \<le> j}. lnth Xs i)"

lemma Sup_upto_llist_mono: "j \<le> k \<Longrightarrow> Sup_upto_llist Xs j \<subseteq> Sup_upto_llist Xs k"
  unfolding Sup_upto_llist_def by auto

lemma Sup_upto_llist_subset_Sup_llist: "j \<le> k \<Longrightarrow> Sup_upto_llist Xs j \<subseteq> Sup_llist Xs"
  unfolding Sup_llist_def Sup_upto_llist_def by auto

lemma elem_Sup_llist_imp_Sup_upto_llist: "x \<in> Sup_llist Xs \<Longrightarrow> \<exists>j. x \<in> Sup_upto_llist Xs j"
  unfolding Sup_llist_def Sup_upto_llist_def by blast

lemma finite_Sup_llist_imp_Sup_upto_llist:
  assumes "finite X" and "X \<subseteq> Sup_llist Xs"
  shows "\<exists>k. X \<subseteq> Sup_upto_llist Xs k"
  using assms
proof induct
  case (insert x X)
  then have x: "x \<in> Sup_llist Xs" and X: "X \<subseteq> Sup_llist Xs"
    by simp+
  from x obtain k where k: "x \<in> Sup_upto_llist Xs k"
    using elem_Sup_llist_imp_Sup_upto_llist by fast
  from X obtain k' where k': "X \<subseteq> Sup_upto_llist Xs k'"
    using insert.hyps(3) by fast
  have "insert x X \<subseteq> Sup_upto_llist Xs (max k k')"
    using k k'
    by (metis insert_absorb insert_subset Sup_upto_llist_mono max.cobounded2 max.commute
        order.trans)
  then show ?case
    by fast
qed simp

definition Liminf_llist :: "'a set llist \<Rightarrow> 'a set" where
  "Liminf_llist Xs =
   (\<Union>i \<in> {i. enat i < llength Xs}. \<Inter>j \<in> {j. i \<le> j \<and> enat j < llength Xs}. lnth Xs j)"

lemma Liminf_llist_subset_Sup_llist: "Liminf_llist Xs \<subseteq> Sup_llist Xs"
  unfolding Liminf_llist_def Sup_llist_def by fast

lemma Liminf_llist_LNil[simp]: "Liminf_llist LNil = {}"
  unfolding Liminf_llist_def by simp

lemma Liminf_llist_LCons:
  "Liminf_llist (LCons X Xs) = (if lnull Xs then X else Liminf_llist Xs)" (is "?lhs = ?rhs")
proof (cases "lnull Xs")
  case nnull: False
  show ?thesis
  proof
    {
      fix x
      assume "\<exists>i. enat i \<le> llength Xs
        \<and> (\<forall>j. i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j)"
      then have "\<exists>i. enat (Suc i) \<le> llength Xs
        \<and> (\<forall>j. Suc i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j)"
        by (cases "llength Xs",
            metis not_lnull_conv[THEN iffD1, OF nnull] Suc_le_D eSuc_enat eSuc_ile_mono
              llength_LCons not_less_eq_eq zero_enat_def zero_le,
            metis Suc_leD enat_ord_code(3))
      then have "\<exists>i. enat i < llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j)"
        by (metis Suc_ile_eq Suc_n_not_le_n lift_Suc_mono_le lnth_Suc_LCons nat_le_linear)
    }
    then show "?lhs \<subseteq> ?rhs"
      by (simp add: Liminf_llist_def nnull) (rule subsetI, simp)

    {
      fix x
      assume "\<exists>i. enat i < llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j)"
      then obtain i where
        i: "enat i < llength Xs" and
        j: "\<forall>j. i \<le> j \<and> enat j < llength Xs \<longrightarrow> x \<in> lnth Xs j"
        by blast

      have "enat (Suc i) \<le> llength Xs"
        using i by (simp add: Suc_ile_eq)
      moreover have "\<forall>j. Suc i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow> x \<in> lnth (LCons X Xs) j"
        using Suc_ile_eq Suc_le_D j by force
      ultimately have "\<exists>i. enat i \<le> llength Xs \<and> (\<forall>j. i \<le> j \<and> enat j \<le> llength Xs \<longrightarrow>
        x \<in> lnth (LCons X Xs) j)"
        by blast
    }
    then show "?rhs \<subseteq> ?lhs"
      by (simp add: Liminf_llist_def nnull) (rule subsetI, simp)
  qed
qed (simp add: Liminf_llist_def enat_0_iff(1))

lemma lfinite_Liminf_llist: "lfinite Xs \<Longrightarrow> Liminf_llist Xs = (if lnull Xs then {} else llast Xs)"
proof (induction rule: lfinite_induct)
  case (LCons xs)
  then obtain y ys where
    xs: "xs = LCons y ys"
    by (meson not_lnull_conv)
  show ?case
    unfolding xs by (simp add: Liminf_llist_LCons LCons.IH[unfolded xs, simplified] llast_LCons)
qed (simp add: Liminf_llist_def)

lemma Liminf_llist_ltl: "\<not> lnull (ltl Xs) \<Longrightarrow> Liminf_llist Xs = Liminf_llist (ltl Xs)"
  by (metis Liminf_llist_LCons lhd_LCons_ltl lnull_ltlI)

end


(*
Author:
  Mnacho Echenim, Université Grenoble Alpes
*)

theory CHSH_Inequality imports
  Projective_Measurements

begin

section \<open>The CHSH inequality\<close>

text \<open>The local hidden variable assumption for quantum  mechanics was developed to make the case
that quantum theory was incomplete. In this part we formalize the CHSH inequality, which provides
an upper-bound of a quantity involving expectations in a probability space, and exploit this
inequality to show that the local hidden variable assumption does not hold.\<close>

subsection \<open>Inequality statement\<close>

lemma chsh_real:
  fixes A0::real
  assumes "\<bar>A0 * B1\<bar> \<le> 1"
  and "\<bar>A0 * B0\<bar> \<le> 1"
  and "\<bar>A1 * B0\<bar> \<le> 1"
  and "\<bar>A1 * B1\<bar> \<le> 1"
  shows "\<bar>A0 * B1 - A0 * B0 + A1 * B0 + A1*B1\<bar> \<le> 2"
proof -
  have "A0 * B1 - A0 * B0 = A0 * B1 - A0 * B0 + A0 * B1 * A1 * B0 - A0 * B1 * A1 * B0" by simp
  also have "... = A0 * B1 * (1 + A1*B0) - A0 * B0 * (1 + A1* B1)"
    by (metis (no_types, opaque_lifting) add_diff_cancel_right calculation diff_add_eq
        group_cancel.sub1 mult.commute mult.right_neutral
        vector_space_over_itself.scale_left_commute
        vector_space_over_itself.scale_right_diff_distrib
        vector_space_over_itself.scale_right_distrib
        vector_space_over_itself.scale_scale)
  finally have "A0 * B1 - A0 * B0 = A0 * B1 * (1 + A1*B0) - A0 * B0 * (1 + A1* B1)" .
  hence "\<bar>A0 * B1 - A0 * B0\<bar> \<le> \<bar>A0 * B1 * (1 + A1*B0)\<bar> + \<bar>A0 * B0 * (1 + A1* B1)\<bar>" by simp
  also have "... = \<bar>A0 * B1\<bar> * \<bar>(1 + A1*B0)\<bar> + \<bar>A0 * B0\<bar> * \<bar>(1 + A1* B1)\<bar>" by (simp add: abs_mult)
  also have "... \<le> \<bar>(1 + A1*B0)\<bar> + \<bar>(1 + A1* B1)\<bar>"
  proof-
    have "\<bar>A0 * B1\<bar> * \<bar>(1 + A1*B0)\<bar> \<le> \<bar>(1 + A1*B0)\<bar>"
      using assms(1) mult_left_le_one_le[of "\<bar>(1 + A1*B0)\<bar>"] by simp
    moreover have "\<bar>A0 * B0\<bar> *\<bar>(1 + A1* B1)\<bar> \<le> \<bar>(1 + A1* B1)\<bar>"
      using assms mult_left_le_one_le[of "\<bar>(1 + A1*B1)\<bar>"] by simp
    ultimately show ?thesis by simp
  qed
  also have "... = 1 + A1*B0 + 1 + A1* B1" using assms by (simp add: abs_le_iff)
  also have "... = 2 + A1 * B0 + A1 * B1" by simp
  finally have pls: "\<bar>A0 * B1 - A0 * B0\<bar> \<le> 2 + A1 * B0 + A1 * B1" .
  have "A0 * B1 - A0 * B0 = A0 * B1 - A0 * B0 + A0 * B1 * A1 * B0 - A0 * B1 * A1 * B0" by simp
  also have "... = A0 * B1 * (1 - A1*B0) - A0 * B0 * (1 - A1* B1)"
  proof -
    have "A0 * (B1 - (B0 - A1 * (B1 * B0)) - A1 * (B1 * B0)) = A0 * (B1 - B0)"
      by fastforce
    then show ?thesis
      by (metis (no_types) add.commute calculation diff_diff_add mult.right_neutral
          vector_space_over_itself.scale_left_commute
          vector_space_over_itself.scale_right_diff_distrib vector_space_over_itself.scale_scale)
  qed
  finally have "A0 * B1 - A0 * B0 = A0 * B1 * (1 - A1*B0) - A0 * B0 * (1 - A1* B1)" .
  hence "\<bar>A0 * B1 - A0 * B0\<bar> \<le> \<bar>A0 * B1 * (1 - A1*B0)\<bar> + \<bar>A0 * B0 * (1 - A1* B1)\<bar>" by simp
  also have "... = \<bar>A0 * B1\<bar> * \<bar>(1 - A1*B0)\<bar> + \<bar>A0 * B0\<bar> * \<bar>(1 - A1* B1)\<bar>" by (simp add: abs_mult)
  also have "... \<le> \<bar>(1 - A1*B0)\<bar> + \<bar>(1 - A1* B1)\<bar>"
  proof-
    have "\<bar>A0 * B1\<bar> * \<bar>(1 - A1*B0)\<bar> \<le> \<bar>(1 - A1*B0)\<bar>"
      using assms(1) mult_left_le_one_le[of "\<bar>(1 - A1*B0)\<bar>"] by simp
    moreover have "\<bar>A0 * B0\<bar> *\<bar>(1 - A1* B1)\<bar> \<le> \<bar>(1 - A1* B1)\<bar>"
      using assms mult_left_le_one_le[of "\<bar>(1 - A1*B1)\<bar>"] by simp
    ultimately show ?thesis by simp
  qed
  also have "... = 1 - A1*B0 + 1 - A1* B1" using assms by (simp add: abs_le_iff)
  also have "... = 2 - A1 * B0 - A1 * B1" by simp
  finally have mns: "\<bar>A0 * B1 - A0 * B0\<bar> \<le> 2 - (A1 * B0 + A1 * B1)" by simp
  have ls: "\<bar>A0 * B1 - A0 * B0\<bar> \<le> 2 - \<bar>A1 * B0 + A1 * B1\<bar>"
  proof (cases "0 \<le> A1 * B0 + A1 * B1")
  case True
    then show ?thesis using mns by simp
  next
  case False
    then show ?thesis using pls by simp
  qed
  have "\<bar>A0 * B1 - A0 * B0 + A1 * B0 + A1 * B1\<bar> \<le> \<bar>A0 * B1 - A0 * B0\<bar> + \<bar>A1 * B0 + A1 * B1\<bar>"
    by simp
  also have "... \<le> 2" using ls by simp
  finally show ?thesis .
qed

lemma (in prob_space) chsh_expect:
  fixes A0::"'a \<Rightarrow> real"
  assumes "AE w in M. \<bar>A0 w\<bar> \<le> 1"
  and "AE w in M. \<bar>A1 w\<bar> \<le> 1"
  and "AE w in M. \<bar>B0 w\<bar> \<le> 1"
  and "AE w in M. \<bar>B1 w\<bar> \<le> 1"
and "integrable M (\<lambda>w. A0 w * B1 w)"
and "integrable M (\<lambda>w. A1 w * B1 w)"
and "integrable M (\<lambda>w. A1 w * B0 w)"
and "integrable M (\<lambda>w. A0 w * B0 w)"
shows "\<bar>expectation (\<lambda>w. A1 w * B0 w) + expectation (\<lambda>w. A0 w *B1 w) +
  expectation (\<lambda>w. A1 w * B1 w) - expectation (\<lambda>w. A0 w * B0 w)\<bar> \<le> 2"
proof -
  have exeq: "expectation (\<lambda>w. A1 w * B0 w) + expectation (\<lambda>w. A0 w * B1 w) +
    expectation (\<lambda>w. A1 w * B1 w) - expectation (\<lambda>w. A0 w * B0 w) =
    expectation (\<lambda>w. A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w)"
    using assms by auto
  have "\<bar>expectation (\<lambda>w. A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w)\<bar> \<le>
    expectation (\<lambda>w. \<bar>A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w\<bar>)"
    using integral_abs_bound by blast
  also have "... \<le> 2"
  proof (rule integral_le_const)
    show "AE w in M. \<bar>A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w\<bar> \<le> (2::real)"
    proof (rule AE_mp)
      show "AE w in M. \<bar>A0 w\<bar> \<le> 1 \<and> \<bar>A1 w\<bar> \<le> 1 \<and> \<bar>B0 w\<bar> \<le> 1 \<and> \<bar>B1 w\<bar> \<le> 1"
        using assms by simp
      show "AE w in M. \<bar>A0 w\<bar> \<le> 1 \<and> \<bar>A1 w\<bar> \<le> 1 \<and> \<bar>B0 w\<bar> \<le> 1 \<and> \<bar>B1 w\<bar> \<le> 1 \<longrightarrow>
               \<bar>A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w\<bar> \<le> 2"
      proof
        fix w
        assume "w\<in> space M"
        show "\<bar>A0 w\<bar> \<le> 1 \<and> \<bar>A1 w\<bar> \<le> 1 \<and> \<bar>B0 w\<bar> \<le> 1 \<and> \<bar>B1 w\<bar> \<le> 1 \<longrightarrow>
         \<bar>A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w\<bar> \<le> 2"
        proof
          assume ineq: "\<bar>A0 w\<bar> \<le> 1 \<and> \<bar>A1 w\<bar> \<le> 1 \<and> \<bar>B0 w\<bar> \<le> 1 \<and> \<bar>B1 w\<bar> \<le> 1"
          show "\<bar>A0 w * B1 w - A0 w * B0 w + A1 w * B0 w + A1 w * B1 w\<bar> \<le> 2"
          proof (rule chsh_real)
            show "\<bar>A0 w * B1 w\<bar> \<le> 1" using ineq by (simp add: abs_mult mult_le_one)
            show "\<bar>A0 w * B0 w\<bar> \<le> 1" using ineq by (simp add: abs_mult mult_le_one)
            show "\<bar>A1 w * B1 w\<bar> \<le> 1" using ineq by (simp add: abs_mult mult_le_one)
            show "\<bar>A1 w * B0 w\<bar> \<le> 1" using ineq by (simp add: abs_mult mult_le_one)
          qed
        qed
      qed
    qed
    show "integrable M (\<lambda>x. \<bar>A0 x * B1 x - A0 x * B0 x + A1 x * B0 x + A1 x * B1 x\<bar>)"
    proof (rule Bochner_Integration.integrable_abs)
      show "integrable M (\<lambda>x. A0 x * B1 x - A0 x * B0 x + A1 x * B0 x + A1 x * B1 x)"
        using assms by auto
    qed
  qed
  finally show ?thesis using exeq by simp
qed

text \<open>The local hidden variable assumption states that separated quantum measurements are
independent. It is standard for this assumption to be stated in a context where the hidden
variable admits a density; it is stated here in a more general contest involving expectations,
with no assumption on the existence of a density.\<close>

definition pos_rv:: "'a measure \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" where
"pos_rv M Xr \<equiv> Xr \<in> borel_measurable M \<and> (AE w in M. (0::real) \<le> Xr w)"

definition prv_sum:: "'a measure \<Rightarrow> complex Matrix.mat \<Rightarrow> (complex \<Rightarrow> 'a \<Rightarrow> real) \<Rightarrow> bool" where
"prv_sum M A Xr \<equiv> (AE w in M. (\<Sum> a\<in> spectrum A. Xr a w) = 1)"

definition (in cpx_sq_mat) lhv where
"lhv M A B R XA XB \<equiv>
  prob_space M \<and>
  (\<forall>a \<in>spectrum A. pos_rv M (XA a)) \<and>
  (prv_sum M A XA) \<and>
  (\<forall>b \<in>spectrum B. pos_rv M (XB b)) \<and>
  (prv_sum M B XB) \<and>
  (\<forall>a \<in>spectrum A . \<forall>b \<in> spectrum B.
    (integrable M (\<lambda>w. XA a w * XB b w)) \<and>
    integral\<^sup>L M (\<lambda>w. XA a w * XB b w) =
    Re (Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))"

(*definition (in cpx_sq_mat) lhv where
"lhv M A B R XA XB \<equiv>
  prob_space M \<and>
  (\<forall>a \<in>spectrum A. (XA a \<in> borel_measurable M) \<and>
    (AE w in M. ((0::real) \<le> XA a w))) \<and>
  (AE w in M. (\<Sum> a\<in> spectrum A. XA a w) = 1) \<and>
  (\<forall>b \<in>spectrum B. (XB b \<in> borel_measurable M) \<and>
    (AE w in M. (0 \<le> XB b w))) \<and>
  (AE w in M. (\<Sum> b\<in> spectrum B. XB b w) = 1) \<and>
  (\<forall>a \<in>spectrum A . \<forall>b \<in> spectrum B.
    (integrable M (\<lambda>w. XA a w * XB b w)) \<and>
    integral\<^sup>L M (\<lambda>w. XA a w * XB b w) =
    Re (Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))"*)

lemma (in cpx_sq_mat) lhv_posl:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> a \<in> spectrum A. 0 \<le> XA a w)"
proof (rule AE_ball_countable[THEN iffD2])
  show "countable (spectrum A)" using spectrum_finite[of A]
    by (simp add: countable_finite)
  show "\<forall>a\<in>spectrum A. AE w in M. 0 \<le> XA a w" using assms unfolding lhv_def pos_rv_def by simp
qed

lemma (in cpx_sq_mat) lhv_lt1_l:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> a \<in> spectrum A. XA a w \<le> 1)"
proof (rule AE_mp)
  show "AE w in M. (\<forall> a \<in> spectrum A. 0 \<le> XA a w) \<and> (\<Sum> a\<in> spectrum A. XA a w) = 1"
    using lhv_posl assms unfolding lhv_def pos_rv_def prv_sum_def by simp
  show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> XA a w) \<and> (\<Sum>a\<in>spectrum A. XA a w) = 1 \<longrightarrow>
    (\<forall>a\<in>spectrum A. XA a w \<le> 1)"
  proof
    fix w
    assume "w\<in> space M"
    show "(\<forall>a\<in>spectrum A. 0 \<le> XA a w) \<and> (\<Sum>a\<in>spectrum A. XA a w) = 1 \<longrightarrow>
      (\<forall>a\<in>spectrum A. XA a w \<le> 1)"
    proof (rule impI)
      assume pr: "(\<forall>a\<in>spectrum A. 0 \<le> XA a w) \<and> (\<Sum>a\<in>spectrum A. XA a w) = 1"
      show "\<forall>a\<in>spectrum A. XA a w \<le> 1"
      proof
        fix a
        assume "a\<in> spectrum A"
        show "XA a w \<le> 1"
        proof (rule pos_sum_1_le[of "spectrum A"])
          show "finite (spectrum A)" using spectrum_finite[of A] by simp
          show "a \<in> spectrum A" using \<open>a \<in> spectrum A\<close> .
          show " \<forall>i\<in>spectrum A. 0 \<le> XA i w" using pr by simp
          show "(\<Sum>i\<in>spectrum A. XA i w) = 1" using pr by simp
        qed
      qed
    qed
  qed
qed

lemma (in cpx_sq_mat) lhv_posr:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> b \<in> spectrum B. 0 \<le> XB b w)"
proof (rule AE_ball_countable[THEN iffD2])
  show "countable (spectrum B)" using spectrum_finite[of B]
    by (simp add: countable_finite)
  show "\<forall>b\<in>spectrum B. AE w in M. 0 \<le> XB b w" using assms unfolding lhv_def pos_rv_def by simp
qed

lemma (in cpx_sq_mat) lhv_lt1_r:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> a \<in> spectrum B. XB a w \<le> 1)"
proof (rule AE_mp)
  show "AE w in M. (\<forall> a \<in> spectrum B. 0 \<le> XB a w) \<and> (\<Sum> a\<in> spectrum B. XB a w) = 1"
    using lhv_posr assms unfolding lhv_def prv_sum_def pos_rv_def by simp
  show "AE w in M. (\<forall>a\<in>spectrum B. 0 \<le> XB a w) \<and> (\<Sum>a\<in>spectrum B. XB a w) = 1 \<longrightarrow>
    (\<forall>a\<in>spectrum B. XB a w \<le> 1)"
  proof
    fix w
    assume "w\<in> space M"
    show "(\<forall>a\<in>spectrum B. 0 \<le> XB a w) \<and> (\<Sum>a\<in>spectrum B. XB a w) = 1 \<longrightarrow>
      (\<forall>a\<in>spectrum B. XB a w \<le> 1)"
    proof (rule impI)
      assume pr: "(\<forall>a\<in>spectrum B. 0 \<le> XB a w) \<and> (\<Sum>a\<in>spectrum B. XB a w) = 1"
      show "\<forall>a\<in>spectrum B. XB a w \<le> 1"
      proof
        fix a
        assume "a\<in> spectrum B"
        show "XB a w \<le> 1"
        proof (rule pos_sum_1_le[of "spectrum B"])
          show "finite (spectrum B)" using spectrum_finite[of B] by simp
          show "a \<in> spectrum B" using \<open>a \<in> spectrum B\<close> .
          show " \<forall>i\<in>spectrum B. 0 \<le> XB i w" using pr by simp
          show "(\<Sum>i\<in>spectrum B. XB i w) = 1" using pr by simp
        qed
      qed
    qed
  qed
qed

lemma (in cpx_sq_mat) lhv_AE_propl:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> a \<in> spectrum A. 0 \<le> XA a w \<and> XA a w \<le> 1) \<and> (\<Sum> a\<in> spectrum A. XA a w) = 1"
proof (rule AE_conjI)
  show "AE w in M. \<forall>a\<in>spectrum A. 0 \<le> XA a w \<and> XA a w \<le> 1"
  proof (rule AE_mp)
    show "AE w in M. (\<forall> a \<in> spectrum A. 0 \<le> XA a w) \<and> (\<forall> a \<in> spectrum A. XA a w \<le> 1)"
      using assms lhv_posl[of M A] lhv_lt1_l[of M A] by simp
    show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> XA a w) \<and> (\<forall>a\<in>spectrum A. XA a w \<le> 1) \<longrightarrow>
               (\<forall>a\<in>spectrum A. 0 \<le> XA a w \<and> XA a w \<le> 1)" by auto
  qed
  show "AE w in M. (\<Sum>a\<in>spectrum A. XA a w) = 1" using assms unfolding lhv_def prv_sum_def
    by simp
qed

lemma (in cpx_sq_mat) lhv_AE_propr:
  assumes "lhv M A B R XA XB"
  shows "AE w in M. (\<forall> a \<in> spectrum B. 0 \<le> XB a w \<and> XB a w \<le> 1) \<and> (\<Sum> a\<in> spectrum B. XB a w) = 1"
proof (rule AE_conjI)
  show "AE w in M. \<forall>a\<in>spectrum B. 0 \<le> XB a w \<and> XB a w \<le> 1"
  proof (rule AE_mp)
    show "AE w in M. (\<forall> a \<in> spectrum B. 0 \<le> XB a w) \<and> (\<forall> a \<in> spectrum B. XB a w \<le> 1)"
      using assms lhv_posr[of M _ B] lhv_lt1_r[of M _ B] by simp
    show "AE w in M. (\<forall>a\<in>spectrum B. 0 \<le> XB a w) \<and> (\<forall>a\<in>spectrum B. XB a w \<le> 1) \<longrightarrow>
               (\<forall>a\<in>spectrum B. 0 \<le> XB a w \<and> XB a w \<le> 1)" by auto
  qed
  show "AE w in M. (\<Sum>a\<in>spectrum B. XB a w) = 1" using assms unfolding lhv_def prv_sum_def
    by simp
qed

lemma (in cpx_sq_mat) lhv_integral_eq:
  fixes c::real
  assumes "lhv M A B R XA XB"
  and "a\<in> spectrum A"
and "b\<in> spectrum B"
shows "integral\<^sup>L M (\<lambda>w. XA a w * XB b w) =
  Re (Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))"
  using assms unfolding lhv_def by simp

lemma (in cpx_sq_mat) lhv_integrable:
  fixes c::real
  assumes "lhv M A B R XA XB"
  and "a\<in> spectrum A"
and "b\<in> spectrum B"
shows "integrable M (\<lambda>w. XA a w * XB b w)" using assms unfolding lhv_def by simp

lemma (in cpx_sq_mat) lhv_scal_integrable:
  fixes c::real
  assumes "lhv M A B R XA XB"
  and "a\<in> spectrum A"
and "b\<in> spectrum B"
shows "integrable M (\<lambda>w. c *XA a w * d * XB b w)"
proof -
  {
    fix x
    assume "x\<in> space M"
    have "c * d * (XA a x * XB b x) = c * XA a x * d * XB b x" by simp
  } note eq = this
  have "integrable M (\<lambda>w. XA a w * XB b w)" using assms unfolding lhv_def by simp
  hence g:"integrable M (\<lambda>w. c * d * (XA a w * XB b w))" using integrable_real_mult_right by simp
  show ?thesis
  proof (rule Bochner_Integration.integrable_cong[THEN iffD2], simp)
    show "integrable M (\<lambda>w. c * d * (XA a w * XB b w))" using g .
    show "\<And>x. x \<in> space M \<Longrightarrow> c * XA a x * d * XB b x = c * d * (XA a x * XB b x)" using eq by simp
  qed
qed

lemma (in cpx_sq_mat) lhv_lsum_scal_integrable:
  assumes "lhv M A B R XA XB"
  and  "a\<in> spectrum A"
shows "integrable M (\<lambda>x. \<Sum>b\<in>spectrum B. c * XA a x * (f b) * XB b x)"
proof (rule Bochner_Integration.integrable_sum)
  fix b
  assume "b\<in> spectrum B"
  thus "integrable M (\<lambda>x. c * XA a x * f b *XB b x)" using \<open>a\<in> spectrum A\<close> assms
    lhv_scal_integrable[of M] by simp
qed

lemma (in cpx_sq_mat) lhv_sum_integrable:
  assumes "lhv M A B R XA XB"
shows "integrable M (\<lambda>w.  (\<Sum> a \<in> spectrum A. (\<Sum> b \<in> spectrum B. f a * XA a w * g b * XB b w)))"
proof (rule Bochner_Integration.integrable_sum)
  fix a
  assume "a\<in> spectrum A"
  thus "integrable M (\<lambda>x. \<Sum>b\<in>spectrum B. f a * XA a x * g b * XB b x)"
    using assms lhv_lsum_scal_integrable[of M]
    by simp
qed

lemma (in cpx_sq_mat) spectrum_abs_1_weighted_suml:
  assumes "lhv M A B R Va Vb"
and "{Re x |x. x \<in> spectrum A} \<noteq> {}"
  and "{Re x |x. x \<in> spectrum A} \<subseteq> {- 1, 1}"
and "hermitian A"
  and "A\<in> fc_mats"
shows "AE w in M. \<bar>(\<Sum>a\<in>spectrum A. Re a * Va a w)\<bar> \<le> 1"
proof (rule AE_mp)
  show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1"
    using assms lhv_AE_propl[of M A B _ Va] by simp
  show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1 \<longrightarrow>
               \<bar>\<Sum>a\<in>spectrum A. Re a * Va a w\<bar> \<le> 1"
  proof
    fix w
    assume "w\<in> space M"
    show "(\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1 \<longrightarrow>
         \<bar>\<Sum>a\<in>spectrum A. Re a * Va a w\<bar> \<le> 1"
    proof (intro impI)
      assume pr: "(\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1"
      show "\<bar>(\<Sum>a\<in>spectrum A. Re a * Va a w)\<bar> \<le> 1"
      proof (cases "{Re x |x. x \<in> spectrum A} = {- 1, 1}")
        case True
        hence sp: "spectrum A = {-1, 1}" using hermitian_Re_spectrum[of A] assms by simp
        hence scsum: "(\<Sum>a\<in>spectrum A. Re a * Va a w) = Va 1 w - Va (-1) w"
          using sum_2_elems by simp
        have sum: "(\<Sum>a\<in>spectrum A. Va a w) = Va (-1) w + Va 1 w"
          using sp sum_2_elems by simp
        have "\<bar>Va 1 w - Va (-1) w\<bar> \<le> 1"
        proof (rule fct_bound')
          have "1 \<in> spectrum A" using sp by simp
          thus "0 \<le> Va 1 w" using pr  by simp
          have "-1 \<in> spectrum A" using sp by simp
          thus "0 \<le> Va (- 1) w" using pr by simp
          show "Va (- 1) w + Va 1 w = 1" using pr sum by simp
        qed
        thus ?thesis using scsum by simp
      next
        case False
        then show ?thesis
        proof (cases "{Re x |x. x \<in> spectrum A} = {- 1}")
          case True
          hence "spectrum A = {-1}" using hermitian_Re_spectrum[of A] assms by simp
          hence "(\<Sum>a\<in>spectrum A. Re a * Va a w) = - Va (-1) w" by simp
          moreover have "-1 \<in> spectrum A" using \<open>spectrum A = {-1}\<close> by simp
          ultimately show ?thesis using pr by simp
        next
          case False
          hence "{Re x |x. x \<in> spectrum A} = {1}" using assms \<open>{Re x |x. x \<in> spectrum A} \<noteq> {-1, 1}\<close>
            last_subset[of "{Re x |x. x \<in> spectrum A}"] by simp
          hence "spectrum A = {1}" using hermitian_Re_spectrum[of A] assms by simp
          hence "(\<Sum>a\<in>spectrum A. Re a * Va a w) = Va 1 w" by simp
          moreover have "1 \<in> spectrum A" using \<open>spectrum A = {1}\<close> by simp
          ultimately show ?thesis using pr by simp
        qed
      qed
    qed
  qed
qed

lemma (in cpx_sq_mat) spectrum_abs_1_weighted_sumr:
  assumes "lhv M B A R Vb Va"
and "{Re x |x. x \<in> spectrum A} \<noteq> {}"
  and "{Re x |x. x \<in> spectrum A} \<subseteq> {- 1, 1}"
and "hermitian A"
  and "A\<in> fc_mats"
shows "AE w in M. \<bar>(\<Sum>a\<in>spectrum A. Re a * Va a w)\<bar> \<le> 1"
proof (rule AE_mp)
  show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1"
    using assms lhv_AE_propr[of M B A _ Vb] by simp
  show "AE w in M. (\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1 \<longrightarrow>
               \<bar>\<Sum>a\<in>spectrum A. Re a * Va a w\<bar> \<le> 1"
  proof
    fix w
    assume "w\<in> space M"
    show "(\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1 \<longrightarrow>
         \<bar>\<Sum>a\<in>spectrum A. Re a * Va a w\<bar> \<le> 1"
    proof (intro impI)
      assume pr: "(\<forall>a\<in>spectrum A. 0 \<le> Va a w \<and> Va a w \<le> 1) \<and> (\<Sum>a\<in>spectrum A. Va a w) = 1"
      show "\<bar>(\<Sum>a\<in>spectrum A. Re a * Va a w)\<bar> \<le> 1"
      proof (cases "{Re x |x. x \<in> spectrum A} = {- 1, 1}")
        case True
        hence sp: "spectrum A = {-1, 1}" using hermitian_Re_spectrum[of A] assms by simp
        hence scsum: "(\<Sum>a\<in>spectrum A. Re a * Va a w) = Va 1 w - Va (-1) w"
          using sum_2_elems by simp
        have sum: "(\<Sum>a\<in>spectrum A. Va a w) = Va (-1) w + Va 1 w"
          using sp sum_2_elems by simp
        have "\<bar>Va 1 w - Va (-1) w\<bar> \<le> 1"
        proof (rule fct_bound')
          have "1 \<in> spectrum A" using sp by simp
          thus "0 \<le> Va 1 w" using pr  by simp
          have "-1 \<in> spectrum A" using sp by simp
          thus "0 \<le> Va (- 1) w" using pr by simp
          show "Va (- 1) w + Va 1 w = 1" using pr sum by simp
        qed
        thus ?thesis using scsum by simp
      next
        case False
        then show ?thesis
        proof (cases "{Re x |x. x \<in> spectrum A} = {- 1}")
          case True
          hence "spectrum A = {-1}" using hermitian_Re_spectrum[of A] assms by simp
          hence "(\<Sum>a\<in>spectrum A. Re a * Va a w) = - Va (-1) w" by simp
          moreover have "-1 \<in> spectrum A" using \<open>spectrum A = {-1}\<close> by simp
          ultimately show ?thesis using pr by simp
        next
          case False
          hence "{Re x |x. x \<in> spectrum A} = {1}" using assms \<open>{Re x |x. x \<in> spectrum A} \<noteq> {-1, 1}\<close>
            last_subset[of "{Re x |x. x \<in> spectrum A}"] by simp
          hence "spectrum A = {1}" using hermitian_Re_spectrum[of A] assms by simp
          hence "(\<Sum>a\<in>spectrum A. Re a * Va a w) = Va 1 w" by simp
          moreover have "1 \<in> spectrum A" using \<open>spectrum A = {1}\<close> by simp
          ultimately show ?thesis using pr by simp
        qed
      qed
    qed
  qed
qed

definition qt_expect where
"qt_expect A Va = (\<lambda>w. (\<Sum>a\<in>spectrum A. Re a * Va a w))"

lemma (in cpx_sq_mat) spectr_sum_integrable:
assumes "lhv M A B R Va Vb"
shows "integrable M (\<lambda>w. qt_expect A Va w * qt_expect B Vb w)"
proof (rule Bochner_Integration.integrable_cong[THEN iffD2])
  show "M = M" by simp
  show "\<And>w. w \<in> space M \<Longrightarrow> qt_expect A Va w * qt_expect B Vb w =
    (\<Sum>a\<in>spectrum A. (\<Sum>b\<in>spectrum B. Re a * Va a w * Re b * Vb b w))"
  proof -
    fix w
    assume "w\<in> space M"
    show "qt_expect A Va w * qt_expect B Vb w =
      (\<Sum>a\<in>spectrum A. (\<Sum>b\<in>spectrum B. Re a * Va a w * Re b * Vb b w))" unfolding qt_expect_def
      by (metis (mono_tags, lifting) Finite_Cartesian_Product.sum_cong_aux sum_product
          vector_space_over_itself.scale_scale)
  qed
  show "integrable M (\<lambda>w. \<Sum>a\<in>spectrum A. (\<Sum>b\<in>spectrum B. Re a * Va a w * Re b * Vb b w))"
    using lhv_sum_integrable[of M] assms by simp
qed

lemma (in cpx_sq_mat) lhv_sum_integral':
  assumes "lhv M A B R XA XB"
shows "integral\<^sup>L M (\<lambda>w. (\<Sum> a \<in> spectrum A. f a * XA a w) * (\<Sum> b \<in> spectrum B. g b * XB b w)) =
  (\<Sum> a \<in> spectrum A. f a * (\<Sum> b \<in> spectrum B. g b  * integral\<^sup>L M (\<lambda>w. XA a w * XB b w)))"
proof -
  have "integral\<^sup>L M (\<lambda>w. (\<Sum> a \<in> spectrum A. f a * XA a w) * (\<Sum> b \<in> spectrum B. g b * XB b w)) =
    integral\<^sup>L M (\<lambda>w. (\<Sum> a \<in> spectrum A. (\<Sum> b \<in> spectrum B. f a * XA a w * g b * XB b w)))"
  proof (rule Bochner_Integration.integral_cong, simp)
    fix w
    assume "w\<in> space M"
    show "(\<Sum>a\<in>spectrum A. f a * XA a w) * (\<Sum>b\<in>spectrum B. g b * XB b w) =
      (\<Sum>a\<in>spectrum A. (\<Sum>b\<in>spectrum B. f a * XA a w * (g b) * XB b w))"
      by (simp add: sum_product vector_space_over_itself.scale_scale)
  qed
  also have "... = (\<Sum> a \<in> spectrum A.
    integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. f a * XA a w * g b * XB b w)))"
  proof (rule Bochner_Integration.integral_sum)
    fix a
    assume "a\<in> spectrum A"
    thus "integrable M (\<lambda>x. \<Sum>b\<in>spectrum B. f a * XA a x * g b * XB b x)"
      using lhv_lsum_scal_integrable[of M] assms by simp
  qed
  also have "... = (\<Sum> a \<in> spectrum A. f a *
    integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. XA a w * g b * XB b w)))"
  proof -
    have "\<forall> a\<in> spectrum A. integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. f a * XA a w * g b * XB b w)) =
      f a * integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. XA a w * g b * XB b w))"
    proof
      fix a
      assume "a\<in> spectrum A"
      have "(LINT w|M. (\<Sum>b\<in>spectrum B. f a * XA a w * g b * XB b w)) =
        (LINT w|M. f a* (\<Sum>b\<in>spectrum B. XA a w * g b * XB b w))"
      proof (rule Bochner_Integration.integral_cong, simp)
        fix x
        assume "x \<in> space M"
        show "(\<Sum>b\<in>spectrum B. f a * XA a x * g b * XB b x) =
          f a * (\<Sum>b\<in>spectrum B. XA a x * g b * XB b x)"
          by (metis (no_types, lifting) Finite_Cartesian_Product.sum_cong_aux
              vector_space_over_itself.scale_scale vector_space_over_itself.scale_sum_right)
      qed
      also have "... = f a * (LINT w|M. (\<Sum>b\<in>spectrum B. XA a w * g b * XB b w))" by simp
      finally show "(LINT w|M. (\<Sum>b\<in>spectrum B. f a * XA a w * g b * XB b w)) =
        f a * (LINT w|M. (\<Sum>b\<in>spectrum B. XA a w * g b * XB b w))" .
    qed
    thus ?thesis by simp
  qed
  also have "... = (\<Sum> a \<in> spectrum A. f a * (\<Sum> b \<in> spectrum B. g b *
    integral\<^sup>L M (\<lambda>w. XA a w * XB b w)))"
  proof (rule sum.cong, simp)
    fix a
      assume "a\<in> spectrum A"
      have "integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. XA a w * g b * XB b w)) = (\<Sum> b \<in> spectrum B.
      integral\<^sup>L M (\<lambda>w. XA a w * g b * XB b w))"
      proof (rule Bochner_Integration.integral_sum)
        show "\<And>b. b \<in> spectrum B \<Longrightarrow> integrable M (\<lambda>x. XA a x * g b * XB b x)"
        proof -
          fix b
          assume "b\<in> spectrum B"
          thus "integrable M (\<lambda>x. XA a x * g b * XB b x)"
            using assms lhv_scal_integrable[of M _ _ _ _ _ a b 1] \<open>a\<in> spectrum A\<close> by simp
        qed
      qed
      also have "... = (\<Sum> b \<in> spectrum B. g b * integral\<^sup>L M (\<lambda>w. XA a w * XB b w))"
      proof (rule sum.cong, simp)
        fix x
        assume "x\<in> spectrum B"
        have "LINT w|M. XA a w * g x * XB x w = LINT w|M. g x * (XA a w * XB x w)"
          by (rule Bochner_Integration.integral_cong, auto)
        also have "... = g x * (LINT w|M. XA a w * XB x w)"
          using Bochner_Integration.integral_mult_right_zero[of M "g x" "\<lambda>w. XA a w * XB x w"]
          by simp
        finally show "LINT w|M. XA a w * g x * XB x w = g x * (LINT w|M. XA a w * XB x w)" .
      qed
      finally have "integral\<^sup>L M (\<lambda>w. (\<Sum> b \<in> spectrum B. XA a w * g b * XB b w)) =
        (\<Sum> b \<in> spectrum B. g b * integral\<^sup>L M (\<lambda>w. XA a w * XB b w))" .
      thus "f a * (LINT w|M. (\<Sum>b\<in>spectrum B. XA a w * g b * XB b w)) =
        f a * (\<Sum> b \<in> spectrum B. g b * integral\<^sup>L M (\<lambda>w. XA a w * XB b w))" by simp
    qed
  finally show ?thesis .
qed

lemma (in cpx_sq_mat) sum_qt_expect_trace:
  assumes "lhv M A B R XA XB"
  shows "(\<Sum> a \<in> spectrum A. f a * (\<Sum> b \<in> spectrum B. g b * integral\<^sup>L M (\<lambda>w. XA a w * XB b w))) =
    (\<Sum> a \<in> spectrum A. f a * (\<Sum> b \<in> spectrum B. g b *
    Re (Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))))"
proof (rule sum.cong, simp)
  fix a
  assume "a\<in> spectrum A"
  have "(\<Sum>b\<in>spectrum B. g b * (LINT w|M. XA a w * XB b w)) =
       (\<Sum>b\<in>spectrum B. g b *
        Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R)))"
  proof (rule sum.cong, simp)
    fix b
    assume "b\<in> spectrum B"
    show "g b * (LINT w|M. XA a w * XB b w) =
      g b * Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R))"
      using lhv_integral_eq[of M] assms \<open>a \<in> spectrum A\<close> \<open>b \<in> spectrum B\<close> by simp
  qed
  thus "f a * (\<Sum>b\<in>spectrum B. g b * (LINT w|M. XA a w * XB b w)) =
        f a * (\<Sum>b\<in>spectrum B. g b *
        Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R)))" by simp
qed

lemma (in cpx_sq_mat) sum_eigen_projector_trace_dist:
  assumes "hermitian B"
and "A\<in> fc_mats"
and "B\<in> fc_mats"
and "R\<in> fc_mats"
  shows "(\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(A * (eigen_projector B b) * R))) = Complex_Matrix.trace(A * B * R)"
proof -
  have "(\<Sum>b\<in>spectrum B. b * Complex_Matrix.trace (A * eigen_projector B b * R)) =
       (\<Sum>b\<in>spectrum B. Complex_Matrix.trace (A * (b \<cdot>\<^sub>m (eigen_projector B b)) * R))"
  proof (rule sum.cong, simp)
    fix b
    assume "b\<in> spectrum B"
    have "b * Complex_Matrix.trace (A * eigen_projector B b * R) =
      Complex_Matrix.trace (b \<cdot>\<^sub>m (A * eigen_projector B b * R))"
    proof (rule trace_smult[symmetric])
      show "A * eigen_projector B b * R \<in> carrier_mat dimR dimR" using eigen_projector_carrier
          assms fc_mats_carrier dim_eq  \<open>b \<in> spectrum B\<close> cpx_sq_mat_mult by meson
    qed
    also have "... = Complex_Matrix.trace (A * (b \<cdot>\<^sub>m eigen_projector B b) * R)"
    proof -
      have "b \<cdot>\<^sub>m (A * eigen_projector B b * R) = b \<cdot>\<^sub>m (A * (eigen_projector B b * R))"
      proof -
        have "A * eigen_projector B b * R = A * (eigen_projector B b * R)"
          by (metis \<open>b \<in> spectrum B\<close> assms(1) assms(2) assms(3) assms(4) assoc_mult_mat dim_eq
              fc_mats_carrier eigen_projector_carrier)
        thus ?thesis by simp
      qed
      also have "... = A * (b \<cdot>\<^sub>m (eigen_projector B b * R))"
      proof (rule mult_smult_distrib[symmetric])
        show "A \<in> carrier_mat dimR dimR" using eigen_projector_carrier  assms
            fc_mats_carrier dim_eq by simp
        show "eigen_projector B b * R \<in> carrier_mat dimR dimR" using eigen_projector_carrier
            \<open>b \<in> spectrum B\<close> assms fc_mats_carrier dim_eq cpx_sq_mat_mult by blast
      qed
      also have "... = A * ((b \<cdot>\<^sub>m eigen_projector B b) * R)"
      proof -
        have "b \<cdot>\<^sub>m (eigen_projector B b * R) = (b \<cdot>\<^sub>m eigen_projector B b) * R"
        proof (rule mult_smult_assoc_mat[symmetric])
          show "eigen_projector B b \<in> carrier_mat dimR dimR" using eigen_projector_carrier
              \<open>b \<in> spectrum B\<close> assms fc_mats_carrier dim_eq by simp
          show "R \<in> carrier_mat dimR dimR" using assms fc_mats_carrier dim_eq by simp
        qed
        thus ?thesis by simp
      qed
      also have "... = A * (b \<cdot>\<^sub>m eigen_projector B b) * R"
        by (metis \<open>b \<in> spectrum B\<close> assms(1) assms(2) assms(3) assms(4) assoc_mult_mat
            cpx_sq_mat_smult dim_eq fc_mats_carrier eigen_projector_carrier)
      finally have "b \<cdot>\<^sub>m (A * eigen_projector B b * R) = A * (b \<cdot>\<^sub>m eigen_projector B b) * R" .
      then show ?thesis by simp
    qed
    finally show "b * Complex_Matrix.trace (A * eigen_projector B b * R) =
      Complex_Matrix.trace (A * (b \<cdot>\<^sub>m eigen_projector B b) * R)" .
  qed
  also have "... = Complex_Matrix.trace (A *
    (sum_mat (\<lambda>b. b \<cdot>\<^sub>m eigen_projector B b) (spectrum B)) * R)"
  proof (rule trace_sum_mat_mat_distrib, (auto simp add: assms))
    show "finite (spectrum B)" using spectrum_finite[of B] by simp
    fix b
    assume "b\<in> spectrum B"
    show "b \<cdot>\<^sub>m eigen_projector B b \<in> fc_mats"
      by (simp add: \<open>b \<in> spectrum B\<close> assms(1) assms(3) cpx_sq_mat_smult eigen_projector_carrier)
  qed
  also have "... = Complex_Matrix.trace (A * B * R)"
  proof -
    have "sum_mat (\<lambda>b. b \<cdot>\<^sub>m eigen_projector B b) (spectrum B) = B" using make_pm_sum' assms by simp
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma (in cpx_sq_mat) sum_eigen_projector_trace_right:
  assumes "hermitian A"
and "A\<in> fc_mats"
and "B\<in> fc_mats"
shows "(\<Sum> a \<in> spectrum A. Complex_Matrix.trace (a \<cdot>\<^sub>m eigen_projector A a * B)) =
  Complex_Matrix.trace (A * B)"
proof -
  have "sum_mat (\<lambda>a. a \<cdot>\<^sub>m eigen_projector A a * B) (spectrum A) =
    sum_mat (\<lambda>a. a \<cdot>\<^sub>m eigen_projector A a) (spectrum A) * B"
  proof (rule mult_sum_mat_distrib_right)
    show "finite (spectrum A)" using spectrum_finite[of A] by simp
    show "\<And>a. a \<in> spectrum A \<Longrightarrow> a \<cdot>\<^sub>m eigen_projector A a \<in> fc_mats"
      using assms(1) assms(2) cpx_sq_mat_smult eigen_projector_carrier by blast
    show "B\<in> fc_mats" using assms by simp
  qed
  also have "... = A * B" using make_pm_sum' assms by simp
  finally have seq: "sum_mat (\<lambda>a. a \<cdot>\<^sub>m eigen_projector A a * B) (spectrum A) = A * B" .
  have "(\<Sum> a \<in> spectrum A. Complex_Matrix.trace (a \<cdot>\<^sub>m eigen_projector A a * B)) =
    Complex_Matrix.trace (sum_mat (\<lambda>a. a \<cdot>\<^sub>m eigen_projector A a * B) (spectrum A))"
  proof (rule trace_sum_mat[symmetric])
    show "finite (spectrum A)" using spectrum_finite[of A] by simp
    show "\<And>a. a \<in> spectrum A \<Longrightarrow> a \<cdot>\<^sub>m eigen_projector A a * B \<in> fc_mats"
      by (simp add: assms(1) assms(2) assms(3) cpx_sq_mat_mult cpx_sq_mat_smult
          eigen_projector_carrier)
  qed
  also have "... = Complex_Matrix.trace (A * B)" using seq by simp
  finally show ?thesis .
qed

lemma (in cpx_sq_mat) sum_eigen_projector_trace:
  assumes "hermitian A"
  and "hermitian B"
  and "A\<in> fc_mats"
  and "B\<in> fc_mats"
and "R\<in> fc_mats"
  shows "(\<Sum> a \<in> spectrum A.  a *  (\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))) =
    Complex_Matrix.trace(A * B * R)"
proof -
  have "(\<Sum> a \<in> spectrum A.  a *  (\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))) = (\<Sum> a \<in> spectrum A.
    Complex_Matrix.trace (a \<cdot>\<^sub>m eigen_projector A a * (B * R)))"
  proof (rule sum.cong, simp)
    fix a
    assume "a\<in> spectrum A"
    hence "(\<Sum>b\<in>spectrum B. b *
      Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R)) =
      Complex_Matrix.trace (eigen_projector A a * B * R)" using
      sum_eigen_projector_trace_dist[of B "eigen_projector A a" R] assms eigen_projector_carrier
      by blast
    hence "a *  (\<Sum> b \<in> spectrum B. (b *
      Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))) =
      a * Complex_Matrix.trace (eigen_projector A a * B * R)" by simp
    also have "... = Complex_Matrix.trace (a \<cdot>\<^sub>m (eigen_projector A a * B * R))"
      using trace_smult[symmetric, of "eigen_projector A a * B * R" dimR a] assms
       \<open>a \<in> spectrum A\<close> cpx_sq_mat_mult dim_eq fc_mats_carrier eigen_projector_carrier by force
    also have "... = Complex_Matrix.trace (a \<cdot>\<^sub>m eigen_projector A a * (B * R))"
    proof -
      have "a \<cdot>\<^sub>m (eigen_projector A a * B * R) = a \<cdot>\<^sub>m (eigen_projector A a * B) * R"
      proof (rule  mult_smult_assoc_mat[symmetric])
        show "R\<in> carrier_mat dimR dimR" using assms fc_mats_carrier dim_eq by simp
        show "eigen_projector A a * B \<in> carrier_mat dimR dimR" using assms eigen_projector_carrier
            cpx_sq_mat_mult fc_mats_carrier dim_eq \<open>a \<in> spectrum A\<close> by blast
      qed
      also have "... = a \<cdot>\<^sub>m eigen_projector A a * B * R"
      proof -
        have "a \<cdot>\<^sub>m (eigen_projector A a * B) = a \<cdot>\<^sub>m eigen_projector A a * B"
          using mult_smult_assoc_mat[symmetric]
        proof -
          show ?thesis
            by (metis \<open>\<And>nr nc n k B A. \<lbrakk>A \<in> carrier_mat nr n; B \<in> carrier_mat n nc\<rbrakk> \<Longrightarrow>
              k \<cdot>\<^sub>m (A * B) = k \<cdot>\<^sub>m A * B\<close> \<open>a \<in> spectrum A\<close> assms(1) assms(3) assms(4) dim_eq
                fc_mats_carrier eigen_projector_carrier)
        qed
        thus ?thesis by simp
      qed
      also have "... = a \<cdot>\<^sub>m eigen_projector A a * (B * R)"
        by (metis \<open>a \<in> spectrum A\<close> assms(1) assms(3) assms(4) assms(5) assoc_mult_mat
            cpx_sq_mat_smult dim_eq fc_mats_carrier eigen_projector_carrier)
      finally show ?thesis by simp
    qed
    finally show "a *  (\<Sum> b \<in> spectrum B. (b *
      Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))) =
      Complex_Matrix.trace (a \<cdot>\<^sub>m eigen_projector A a * (B * R))"  .
  qed
  also have "... = Complex_Matrix.trace (A * (B * R))"
    using sum_eigen_projector_trace_right[of A "B * R"] assms by (simp add: cpx_sq_mat_mult)
  also have "... = Complex_Matrix.trace (A * B * R)"
  proof -
    have "A * (B * R) = A * B * R"
    proof (rule assoc_mult_mat[symmetric])
      show "A\<in>  carrier_mat dimR dimR" using assms fc_mats_carrier dim_eq by simp
      show "B\<in>  carrier_mat dimR dimR" using assms fc_mats_carrier dim_eq by simp
      show "R\<in>  carrier_mat dimR dimR" using assms fc_mats_carrier dim_eq by simp
    qed
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

text \<open>We obtain the main result of this part, which relates the quantum expectation value of a
joint measurement with an expectation.\<close>

lemma (in cpx_sq_mat) sum_qt_expect:
  assumes "lhv M A B R XA XB"
  and "A\<in> fc_mats"
  and "B\<in> fc_mats"
  and "R\<in> fc_mats"
  and "hermitian A"
  and "hermitian B"
  shows "integral\<^sup>L M (\<lambda>w. (qt_expect A XA w) * (qt_expect B XB w)) =
    Re (Complex_Matrix.trace(A * B * R))"
proof -
  have br: "\<forall> b \<in> spectrum B. b\<in> Reals" using assms hermitian_spectrum_real[of B] by auto
  have ar: "\<forall>a \<in> spectrum A. a\<in> Reals" using hermitian_spectrum_real[of A] assms by auto
  have "integral\<^sup>L M (\<lambda>w. (\<Sum> a \<in> spectrum A. Re a* XA a w) * (\<Sum> b \<in> spectrum B. Re b *XB b w)) =
    (\<Sum> a \<in> spectrum A. Re a * (\<Sum> b \<in> spectrum B. Re b * integral\<^sup>L M (\<lambda>w. XA a w * XB b w)))"
    using lhv_sum_integral'[of M] assms by simp
  also have "... = (\<Sum> a \<in> spectrum A. Re a * (\<Sum> b \<in> spectrum B. Re b *
    Re (Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))))"
    using assms sum_qt_expect_trace[of M] by simp
  also have "... = (\<Sum> a \<in> spectrum A. Re a * Re (\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))))"
  proof (rule sum.cong, simp)
    fix a
    assume "a\<in> spectrum A"
    have "(\<Sum>b\<in>spectrum B. Re b *
      Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R))) =
      (\<Sum> b \<in> spectrum B. Re (b *
      Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))"
    proof (rule sum.cong, simp)
      fix b
      assume "b\<in> spectrum B"
      hence "b\<in> Reals" using hermitian_spectrum_real[of B] assms by simp
      hence "Re b = b" by simp
      thus "Re b * Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R)) =
         Re (b * Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R))"
        using hermitian_spectrum_real using \<open>b \<in> \<real>\<close> mult_real_cpx by auto
    qed
    also have "... =
      Re (\<Sum> b \<in> spectrum B. b *
        Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))" by simp
    finally have "(\<Sum>b\<in>spectrum B. Re b *
      Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R))) =
      Re (\<Sum> b \<in> spectrum B. b *
        Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))" .
    thus "Re a * (\<Sum>b\<in>spectrum B. Re b *
      Re (Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R))) =
         Re a * Re (\<Sum>b\<in>spectrum B.
          (b * Complex_Matrix.trace (eigen_projector A a * eigen_projector B b * R)))"
      by simp
  qed
  also have "... =  (\<Sum> a \<in> spectrum A. Re (a * (\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R)))))"
  proof (rule sum.cong, simp)
    fix x
    assume "x\<in> spectrum A"
    hence "Re x = x" using ar by simp
    thus "Re x * Re (\<Sum>b\<in>spectrum B. b *
      Complex_Matrix.trace (eigen_projector A x * eigen_projector B b * R)) =
         Re (x * (\<Sum>b\<in>spectrum B. b *
        Complex_Matrix.trace (eigen_projector A x * eigen_projector B b * R)))"
      using \<open>x \<in> spectrum A\<close> ar mult_real_cpx by auto
  qed
  also have "... = Re (\<Sum> a \<in> spectrum A.  a *  (\<Sum> b \<in> spectrum B. (b *
    Complex_Matrix.trace(eigen_projector A a * (eigen_projector B b) * R))))" by simp
  also have "... = Re (Complex_Matrix.trace(A *B * R))" using assms
    sum_eigen_projector_trace[of A B] by simp
  finally show ?thesis unfolding qt_expect_def .
qed

subsection \<open>Properties of specific observables\<close>

text \<open>In this part we consider a specific density operator and specific observables corresponding
to joint bipartite measurements. We will compute the quantum expectation value of this system and
prove that it violates the CHSH inequality, thus proving that the local hidden variable assumption
cannot hold.\<close>

subsubsection \<open>Ket 0, Ket 1 and the corresponding projectors\<close>

definition ket_0::"complex Matrix.vec" where
"ket_0 = unit_vec 2 0"

lemma ket_0_dim:
  shows "dim_vec ket_0 = 2" unfolding ket_0_def by simp

lemma ket_0_norm:
  shows "\<parallel>ket_0\<parallel> = 1" using unit_cpx_vec_length unfolding ket_0_def by simp

lemma ket_0_mat:
  shows "ket_vec ket_0 =  Matrix.mat_of_cols_list 2 [[1, 0]]"
  by (auto simp add: ket_vec_def Matrix.mat_of_cols_list_def ket_0_def)

definition ket_1::"complex Matrix.vec" where
"ket_1 = unit_vec 2 1"

lemma ket_1_dim:
  shows "dim_vec ket_1 = 2" unfolding ket_1_def by simp

lemma ket_1_norm:
  shows "\<parallel>ket_1\<parallel> = 1" using unit_cpx_vec_length unfolding ket_1_def by simp

definition ket_01
  where "ket_01 = tensor_vec ket_0 ket_1"

lemma ket_01_dim:
  shows "dim_vec ket_01 = 4" unfolding ket_01_def
  by (simp add: ket_0_dim ket_1_dim)

definition  ket_10
  where "ket_10 = tensor_vec ket_1 ket_0"

lemma ket_10_dim:
  shows "dim_vec ket_10 = 4" unfolding ket_10_def by (simp add: ket_0_dim ket_1_dim)

text \<open>We define \verb+ket_psim+, one of the Bell states (or EPR pair).\<close>

definition ket_psim where
"ket_psim = 1/(sqrt 2) \<cdot>\<^sub>v (ket_01 - ket_10)"

lemma  ket_psim_dim:
  shows "dim_vec ket_psim = 4" using ket_01_dim ket_10_dim unfolding ket_psim_def by simp

lemma ket_psim_norm:
  shows "\<parallel>ket_psim\<parallel> = 1"
proof -
  have "dim_vec ket_psim = 2\<^sup>2" unfolding ket_psim_def ket_01_def ket_10_def ket_0_def ket_1_def
  by simp
  moreover have "(\<Sum>i<4. (cmod (vec_index ket_psim i))\<^sup>2) = 1"
    apply (auto simp add: ket_psim_def ket_01_def ket_10_def ket_0_def ket_1_def)
    apply (simp add: sum_4_elems)
    done
  ultimately show ?thesis by (simp add: cpx_vec_length_def)
qed

text \<open>\verb+rho_psim+ represents the density operator associated with the quantum
state \verb+ket_psim+.\<close>

definition  rho_psim where
"rho_psim = rank_1_proj ket_psim"

lemma rho_psim_carrier:
  shows "rho_psim \<in> carrier_mat 4 4" using rank_1_proj_carrier[of ket_psim] ket_psim_dim
    rho_psim_def by simp

lemma  rho_psim_dim_row:
  shows "dim_row rho_psim = 4" using rho_psim_carrier by simp

lemma rho_psim_density:
  shows "density_operator rho_psim" unfolding density_operator_def
proof
  show "Complex_Matrix.positive rho_psim" using rank_1_proj_positive[of ket_psim] ket_psim_norm
      rho_psim_def by simp
  show "Complex_Matrix.trace rho_psim = 1" using rank_1_proj_trace[of ket_psim] ket_psim_norm
      rho_psim_def by simp
qed

subsubsection \<open>The X and Z matrices and two of their combinations\<close>

text \<open>In this part we prove properties of two standard matrices in quantum theory, $X$ and $Z$,
as well as two of their combinations: $\frac{X+Z}{\sqrt{2}}$ and $\frac{Z - X}{\sqrt{2}}$.
Note that all of these matrices are observables, they will be used to violate the CHSH inequality.\<close>

lemma Z_carrier: shows "Z \<in> carrier_mat 2 2" unfolding Z_def by simp

lemma Z_hermitian:
  shows "hermitian Z" using dagger_adjoint dagger_of_Z unfolding  hermitian_def by simp

lemma unitary_Z:
  shows "Complex_Matrix.unitary Z"
proof -
  have "Complex_Matrix.adjoint Z * Z = (1\<^sub>m 2)" using dagger_adjoint[of Z] by simp
  thus ?thesis unfolding unitary_def
    by (metis Complex_Matrix.adjoint_adjoint Complex_Matrix.unitary_def Z_carrier adjoint_dim
        carrier_matD(1) inverts_mat_def unitary_adjoint)
qed

lemma X_carrier: shows "X \<in> carrier_mat 2 2" unfolding X_def by simp

lemma X_hermitian:
  shows "hermitian X" using dagger_adjoint dagger_of_X unfolding  hermitian_def by simp

lemma unitary_X:
  shows "Complex_Matrix.unitary X"
proof -
  have "Complex_Matrix.adjoint X * X = (1\<^sub>m 2)" using dagger_adjoint[of X] by simp
  thus ?thesis unfolding unitary_def
    by (metis Complex_Matrix.adjoint_adjoint Complex_Matrix.unitary_def X_carrier adjoint_dim
        carrier_matD(1) inverts_mat_def unitary_adjoint)
qed

definition XpZ
  where "XpZ = -1/sqrt(2) \<cdot>\<^sub>m (X + Z)"

lemma XpZ_carrier:
  shows "XpZ \<in> carrier_mat 2 2" unfolding XpZ_def X_def Z_def by simp

lemma XpZ_hermitian:
  shows "hermitian XpZ"
proof -
  have "X + Z \<in> carrier_mat 2 2" using Z_carrier X_carrier by simp
  moreover have "hermitian (X + Z)" using X_hermitian Z_hermitian hermitian_add Matrix.mat_carrier
    unfolding X_def Z_def  by blast
  ultimately show ?thesis using hermitian_smult[of "X + Z" 2 "- 1 / sqrt 2"] unfolding XpZ_def
    by auto
qed

lemma XpZ_inv:
  "XpZ * XpZ = 1\<^sub>m 2" unfolding XpZ_def X_def Z_def times_mat_def one_mat_def
  apply (rule cong_mat, simp+)
  apply (auto simp add: Matrix.scalar_prod_def)
   apply (auto simp add: Gates.csqrt_2_sq)
  done

lemma unitary_XpZ:
  shows "Complex_Matrix.unitary XpZ"
proof -
  have "Complex_Matrix.adjoint XpZ * XpZ = (1\<^sub>m 2)" using XpZ_inv XpZ_hermitian
    unfolding hermitian_def by simp
  thus ?thesis unfolding unitary_def
    by (metis Complex_Matrix.adjoint_adjoint Complex_Matrix.unitary_def XpZ_carrier adjoint_dim
        carrier_matD(1) inverts_mat_def unitary_adjoint)
qed

definition ZmX
  where "ZmX = 1/sqrt(2) \<cdot>\<^sub>m (Z - X)"

lemma ZmX_carrier:
  shows "ZmX \<in> carrier_mat 2 2" unfolding ZmX_def X_def Z_def
  by (simp add: minus_carrier_mat')

lemma ZmX_hermitian:
  shows "hermitian ZmX"
proof -
  have "Z - X \<in> carrier_mat 2 2" unfolding X_def Z_def
    by (simp add: minus_carrier_mat)
  moreover have "hermitian (Z - X)" using X_hermitian Z_hermitian hermitian_minus Matrix.mat_carrier
    unfolding X_def Z_def by blast
  ultimately show ?thesis using hermitian_smult[of "Z - X" 2 "1 / sqrt 2"] unfolding ZmX_def
    by auto
qed

lemma ZmX_inv:
  "ZmX * ZmX = 1\<^sub>m 2" unfolding ZmX_def X_def Z_def times_mat_def one_mat_def
  apply (rule cong_mat, simp+)
  apply (auto simp add: Matrix.scalar_prod_def)
   apply (auto simp add: Gates.csqrt_2_sq)
  done

lemma unitary_ZmX:
  shows "Complex_Matrix.unitary ZmX"
proof -
  have "Complex_Matrix.adjoint ZmX * ZmX = (1\<^sub>m 2)" using ZmX_inv ZmX_hermitian
    unfolding hermitian_def by simp
  thus ?thesis unfolding unitary_def
    by (metis Complex_Matrix.adjoint_adjoint Complex_Matrix.unitary_def ZmX_carrier adjoint_dim
        carrier_matD(1) inverts_mat_def unitary_adjoint)
qed

definition  Z_XpZ
  where "Z_XpZ = tensor_mat Z XpZ"

lemma Z_XpZ_carrier:
  shows "Z_XpZ \<in> carrier_mat 4 4" unfolding Z_XpZ_def using tensor_mat_carrier XpZ_carrier
    Z_carrier by auto

definition X_XpZ
  where "X_XpZ = tensor_mat X XpZ"

lemma X_XpZ_carrier:
  shows "X_XpZ \<in> carrier_mat 4 4" using tensor_mat_carrier XpZ_carrier X_carrier
  unfolding X_XpZ_def by auto

definition Z_ZmX
  where "Z_ZmX = tensor_mat Z ZmX"

lemma Z_ZmX_carrier:
  shows "Z_ZmX \<in> carrier_mat 4 4" using tensor_mat_carrier ZmX_carrier Z_carrier
  unfolding Z_ZmX_def by auto

definition X_ZmX
  where "X_ZmX = tensor_mat X ZmX"

lemma X_ZmX_carrier:
  shows "X_ZmX \<in> carrier_mat 4 4" using tensor_mat_carrier X_carrier ZmX_carrier
  unfolding X_ZmX_def by auto

lemma  X_ZmX_rho_psim[simp]:
  shows "Complex_Matrix.trace (rho_psim * X_ZmX) = 1/ (sqrt 2)"
  apply (auto simp add: ket_10_def ket_1_def X_ZmX_def ZmX_def X_def ket_01_def
      Z_def rho_psim_def ket_psim_def rank_1_proj_def outer_prod_def ket_0_def)
  apply (auto simp add: Complex_Matrix.trace_def)
  apply (simp add: sum_4_elems)
  apply (simp add: csqrt_2_sq)
  done

lemma  Z_ZmX_rho_psim[simp]:
  shows "Complex_Matrix.trace (rho_psim * Z_ZmX) = -1/ (sqrt 2)"
  apply (auto simp add: rho_psim_def ket_psim_def ket_10_def)
  apply (auto simp add: Z_ZmX_def Z_def ZmX_def X_def)
  apply (auto simp add: rank_1_proj_def outer_prod_def ket_01_def ket_1_def ket_0_def)
  apply (auto simp add: Complex_Matrix.trace_def sum_4_elems)
  apply (simp add: csqrt_2_sq)
  done

lemma X_XpZ_rho_psim[simp]:
  shows "Complex_Matrix.trace (rho_psim * X_XpZ) =1/ (sqrt 2)"
  apply (auto simp add: rho_psim_def ket_psim_def ket_10_def)
  apply (auto simp add: X_XpZ_def Z_def XpZ_def X_def)
  apply (auto simp add: rank_1_proj_def outer_prod_def ket_01_def ket_1_def ket_0_def)
  apply (auto simp add: Complex_Matrix.trace_def sum_4_elems)
  apply (simp add: csqrt_2_sq)
  done

lemma Z_XpZ_rho_psim[simp]:
  shows "Complex_Matrix.trace (rho_psim * Z_XpZ) =1/ (sqrt 2)"
  apply (auto simp add: rho_psim_def ket_psim_def ket_10_def)
  apply (auto simp add: Z_XpZ_def  XpZ_def X_def Z_def)
  apply (auto simp add: rank_1_proj_def outer_prod_def ket_01_def ket_1_def ket_0_def)
  apply (auto simp add: Complex_Matrix.trace_def sum_4_elems)
  apply (simp add: csqrt_2_sq)
  done

definition Z_I where
"Z_I = tensor_mat Z (1\<^sub>m 2)"

lemma Z_I_carrier:
  shows "Z_I \<in> carrier_mat 4 4" using tensor_mat_carrier Z_carrier unfolding Z_I_def by auto

lemma Z_I_hermitian:
  shows "hermitian Z_I" unfolding Z_I_def using tensor_mat_hermitian[of Z 2 "1\<^sub>m 2" 2]
  by (simp add: Z_carrier Z_hermitian hermitian_one)

lemma  Z_I_unitary:
  shows "unitary Z_I" unfolding Z_I_def using tensor_mat_unitary[of Z "1\<^sub>m 2"] Z_carrier unitary_Z
  using unitary_one by auto

lemma Z_I_spectrum:
  shows "{Re x |x. x \<in> spectrum Z_I} \<subseteq> {- 1, 1}" using unitary_hermitian_Re_spectrum Z_I_hermitian
    Z_I_unitary Z_I_carrier by simp

definition X_I where
"X_I = tensor_mat X (1\<^sub>m 2)"

lemma  X_I_carrier:
  shows "X_I \<in> carrier_mat 4 4" using tensor_mat_carrier X_carrier unfolding X_I_def by auto

lemma X_I_hermitian:
  shows "hermitian X_I" unfolding X_I_def using tensor_mat_hermitian[of X 2 "1\<^sub>m 2" 2]
  by (simp add: X_carrier X_hermitian hermitian_one)

lemma X_I_unitary:
  shows "unitary X_I" unfolding X_I_def using tensor_mat_unitary[of X "1\<^sub>m 2"] X_carrier unitary_X
  using unitary_one by auto

lemma  X_I_spectrum:
  shows "{Re x |x. x \<in> spectrum X_I} \<subseteq> {- 1, 1}" using unitary_hermitian_Re_spectrum X_I_hermitian
    X_I_unitary X_I_carrier by simp

definition  I_XpZ where
"I_XpZ = tensor_mat (1\<^sub>m 2) XpZ"

lemma  I_XpZ_carrier:
  shows "I_XpZ \<in> carrier_mat 4 4" using tensor_mat_carrier XpZ_carrier unfolding I_XpZ_def by auto

lemma  I_XpZ_hermitian:
  shows "hermitian I_XpZ" unfolding I_XpZ_def using tensor_mat_hermitian[of "1\<^sub>m 2" 2 XpZ 2]
  by (simp add: XpZ_carrier XpZ_hermitian hermitian_one)

lemma I_XpZ_unitary:
  shows "unitary I_XpZ" unfolding I_XpZ_def using tensor_mat_unitary[of "1\<^sub>m 2" XpZ] XpZ_carrier
    unitary_XpZ using unitary_one by auto

lemma I_XpZ_spectrum:
  shows "{Re x |x. x \<in> spectrum I_XpZ} \<subseteq> {- 1, 1}" using unitary_hermitian_Re_spectrum
    I_XpZ_hermitian I_XpZ_unitary I_XpZ_carrier by simp

definition I_ZmX where
"I_ZmX = tensor_mat (1\<^sub>m 2) ZmX"

lemma  I_ZmX_carrier:
  shows "I_ZmX \<in> carrier_mat 4 4" using tensor_mat_carrier ZmX_carrier unfolding I_ZmX_def by auto

lemma I_ZmX_hermitian:
  shows "hermitian I_ZmX" unfolding I_ZmX_def using tensor_mat_hermitian[of "1\<^sub>m 2" 2 ZmX 2]
  by (simp add: ZmX_carrier ZmX_hermitian hermitian_one)

lemma I_ZmX_unitary:
  shows "unitary I_ZmX" unfolding I_ZmX_def using tensor_mat_unitary[of "1\<^sub>m 2" ZmX] ZmX_carrier
    unitary_ZmX using unitary_one by auto

lemma I_ZmX_spectrum:
  shows "{Re x |x. x \<in> spectrum I_ZmX} \<subseteq> {- 1, 1}" using unitary_hermitian_Re_spectrum I_ZmX_hermitian
    I_ZmX_unitary I_ZmX_carrier by simp

lemma X_I_ZmX_eq:
  shows "X_I * I_ZmX = X_ZmX" unfolding X_I_def I_ZmX_def X_ZmX_def using mult_distr_tensor
  by (metis (no_types, lifting) X_inv ZmX_inv index_mult_mat(2) index_mult_mat(3) index_one_mat(2)
      index_one_mat(3) left_mult_one_mat' pos2 right_mult_one_mat')

lemma X_I_XpZ_eq:
  shows "X_I * I_XpZ = X_XpZ" unfolding X_I_def I_XpZ_def X_XpZ_def using mult_distr_tensor
  by (metis (no_types, lifting) X_inv XpZ_inv index_mult_mat(2) index_mult_mat(3) index_one_mat(2)
      index_one_mat(3) left_mult_one_mat' pos2 right_mult_one_mat')

lemma Z_I_XpZ_eq:
  shows "Z_I * I_XpZ = Z_XpZ" unfolding Z_I_def I_XpZ_def Z_XpZ_def using mult_distr_tensor
  by (metis (no_types, lifting) Z_inv XpZ_inv index_mult_mat(2) index_mult_mat(3) index_one_mat(2)
      index_one_mat(3) left_mult_one_mat' pos2 right_mult_one_mat')

lemma Z_I_ZmX_eq:
  shows "Z_I * I_ZmX = Z_ZmX" unfolding Z_I_def I_ZmX_def Z_ZmX_def using mult_distr_tensor
  by (metis (no_types, lifting) Z_inv ZmX_inv index_mult_mat(2) index_mult_mat(3) index_one_mat(2)
      index_one_mat(3) left_mult_one_mat' pos2 right_mult_one_mat')

subsubsection \<open>No local hidden variable\<close>

text \<open>We show that the local hidden variable hypothesis cannot hold by exhibiting a quantum
expectation value that is greater than the upper-bound givven by the CHSH inequality.\<close>

locale bin_cpx = cpx_sq_mat +
  assumes dim4: "dimR = 4"

lemma (in bin_cpx) X_I_XpZ_trace:
  assumes "lhv M X_I I_XpZ R Vx Vp"
  and "R\<in> fc_mats"
  shows "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_XpZ  Vp w) =
  Re (Complex_Matrix.trace (R * X_XpZ))"
proof -
  have "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_XpZ  Vp w) =
  Re (Complex_Matrix.trace (X_I * I_XpZ * R))"
  proof (rule sum_qt_expect, (simp add: assms))
    show "X_I \<in> fc_mats" using X_I_carrier dim4  fc_mats_carrier dim_eq by simp
    show "R\<in> fc_mats" using assms by simp
    show "I_XpZ \<in> fc_mats" using I_XpZ_carrier dim4 fc_mats_carrier dim_eq by simp
    show "hermitian X_I" using X_I_hermitian .
    show "hermitian I_XpZ" using I_XpZ_hermitian .
  qed
  also have "... = Re (Complex_Matrix.trace (X_XpZ * R))" using X_I_XpZ_eq by simp
  also have "... = Re (Complex_Matrix.trace (R * X_XpZ))"
  proof -
    have "Complex_Matrix.trace (X_XpZ * R) = Complex_Matrix.trace (R * X_XpZ)"
      using trace_comm[of X_XpZ 4 R] X_XpZ_carrier assms dim4 fc_mats_carrier dim_eq by simp
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma (in bin_cpx) X_I_XpZ_chsh:
  assumes "lhv M X_I I_XpZ rho_psim Vx Vp"
  shows "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_XpZ Vp w) =
  1/sqrt 2"
proof -
  have "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_XpZ Vp w) =
  Re (Complex_Matrix.trace (rho_psim * X_XpZ))"
  proof (rule X_I_XpZ_trace, (simp add: assms))
    show "rho_psim \<in> fc_mats" using rho_psim_carrier fc_mats_carrier dim_eq dim4 by simp
  qed
  also have "... = 1/sqrt 2" using X_XpZ_rho_psim by simp
  finally show ?thesis .
qed

lemma (in bin_cpx) Z_I_XpZ_trace:
  assumes "lhv M Z_I I_XpZ R Vz Vp"
  and "R\<in> fc_mats"
  shows "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_XpZ Vp w) =
  Re (Complex_Matrix.trace (R * Z_XpZ))"
proof -
  have "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_XpZ Vp w) =
  Re (Complex_Matrix.trace (Z_I * I_XpZ * R))"
  proof (rule sum_qt_expect, (simp add: assms))
    show "Z_I \<in> fc_mats" using Z_I_carrier dim4 fc_mats_carrier dim_eq by simp
    show "R\<in> fc_mats" using assms by simp
    show "I_XpZ \<in> fc_mats" using I_XpZ_carrier dim4 fc_mats_carrier dim_eq by simp
    show "hermitian Z_I" using Z_I_hermitian .
    show "hermitian I_XpZ" using I_XpZ_hermitian .
  qed
  also have "... = Re (Complex_Matrix.trace (Z_XpZ * R))" using Z_I_XpZ_eq by simp
  also have "... = Re (Complex_Matrix.trace (R * Z_XpZ))"
  proof -
    have "Complex_Matrix.trace (Z_XpZ * R) = Complex_Matrix.trace (R * Z_XpZ)"
      using trace_comm[of Z_XpZ 4 R] Z_XpZ_carrier assms dim4 fc_mats_carrier dim_eq by simp
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma (in bin_cpx) Z_I_XpZ_chsh:
  assumes "lhv M Z_I I_XpZ rho_psim Vz Vp"
  shows "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_XpZ Vp w) =
  1/sqrt 2"
proof -
  have "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_XpZ Vp w) =
  Re (Complex_Matrix.trace (rho_psim * Z_XpZ))"
  proof (rule Z_I_XpZ_trace, (simp add: assms))
    show "rho_psim \<in> fc_mats" using rho_psim_carrier fc_mats_carrier dim_eq dim4 by simp
  qed
  also have "... = 1/sqrt 2" using Z_XpZ_rho_psim by simp
  finally show ?thesis unfolding qt_expect_def .
qed

lemma (in bin_cpx) X_I_ZmX_trace:
  assumes "lhv M X_I I_ZmX R Vx Vp"
  and "R\<in> fc_mats"
  shows "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (R * X_ZmX))"
proof -
  have "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (X_I * I_ZmX * R))"
  proof (rule sum_qt_expect, (simp add: assms))
    show "X_I \<in> fc_mats" using X_I_carrier dim4 fc_mats_carrier dim_eq by simp
    show "R\<in> fc_mats" using assms by simp
    show "I_ZmX \<in> fc_mats" using I_ZmX_carrier dim4 fc_mats_carrier dim_eq by simp
    show "hermitian X_I" using X_I_hermitian .
    show "hermitian I_ZmX" using I_ZmX_hermitian .
  qed
  also have "... = Re (Complex_Matrix.trace (X_ZmX * R))" using X_I_ZmX_eq by simp
  also have "... = Re (Complex_Matrix.trace (R * X_ZmX))"
  proof -
    have "Complex_Matrix.trace (X_ZmX * R) = Complex_Matrix.trace (R * X_ZmX)"
      using trace_comm[of X_ZmX 4 R] X_ZmX_carrier assms dim4 fc_mats_carrier dim_eq by simp
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma (in bin_cpx) X_I_ZmX_chsh:
  assumes "lhv M X_I I_ZmX rho_psim Vx Vp"
  shows "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_ZmX Vp w) =
  1/sqrt 2"
proof -
  have "LINT w|M. (qt_expect X_I Vx w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (rho_psim * X_ZmX))"
  proof (rule X_I_ZmX_trace, (simp add: assms))
    show "rho_psim \<in> fc_mats" using rho_psim_carrier fc_mats_carrier dim_eq dim4 by simp
  qed
  also have "... = 1/sqrt 2" using X_ZmX_rho_psim by simp
  finally show ?thesis unfolding qt_expect_def .
qed

lemma (in bin_cpx) Z_I_ZmX_trace:
  assumes "lhv M Z_I I_ZmX R Vz Vp"
  and "R\<in> fc_mats"
  shows "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (R * Z_ZmX))"
proof -
  have "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (Z_I * I_ZmX * R))"
  proof (rule sum_qt_expect, (simp add: assms))
    show "Z_I \<in> fc_mats" using Z_I_carrier dim4 fc_mats_carrier dim_eq by simp
    show "R\<in> fc_mats" using assms by simp
    show "I_ZmX \<in> fc_mats" using I_ZmX_carrier dim4 fc_mats_carrier dim_eq by simp
    show "hermitian Z_I" using Z_I_hermitian .
    show "hermitian I_ZmX" using I_ZmX_hermitian .
  qed
  also have "... = Re (Complex_Matrix.trace (Z_ZmX * R))" using Z_I_ZmX_eq by simp
  also have "... = Re (Complex_Matrix.trace (R * Z_ZmX))"
  proof -
    have "Complex_Matrix.trace (Z_ZmX * R) = Complex_Matrix.trace (R * Z_ZmX)"
      using trace_comm[of Z_ZmX 4 R] Z_ZmX_carrier assms dim4 fc_mats_carrier dim_eq by simp
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma (in bin_cpx) Z_I_ZmX_chsh:
  assumes "lhv M Z_I I_ZmX rho_psim Vz Vp"
shows "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_ZmX Vp w) =
  -1/sqrt 2"
proof -
  have "LINT w|M. (qt_expect Z_I Vz w) * (qt_expect I_ZmX Vp w) =
  Re (Complex_Matrix.trace (rho_psim * Z_ZmX))"
  proof (rule Z_I_ZmX_trace, (simp add: assms))
    show "rho_psim \<in> fc_mats" using rho_psim_carrier fc_mats_carrier dim_eq dim4 by simp
  qed
  also have "... = -1/sqrt 2" using Z_ZmX_rho_psim by simp
  finally show ?thesis unfolding qt_expect_def .
qed

lemma (in bin_cpx) chsh_upper_bound:
  assumes "prob_space M"
  and "lhv M X_I I_XpZ rho_psim Vx Vp"
  and "lhv M Z_I I_XpZ rho_psim Vz Vp"
  and "lhv M X_I I_ZmX rho_psim Vx Vm"
  and "lhv M Z_I I_ZmX rho_psim Vz Vm"
shows "\<bar>(LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w) +
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w) +
        (LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w) -
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w)\<bar>
  \<le> 2"
proof (rule prob_space.chsh_expect)
  show "AE w in M. \<bar>qt_expect X_I Vx w\<bar> \<le> 1" unfolding qt_expect_def
  proof (rule spectrum_abs_1_weighted_suml)
    show "X_I \<in> fc_mats" using X_I_carrier fc_mats_carrier dim_eq dim4 by simp
    show "hermitian X_I" using X_I_hermitian .
    show "lhv M X_I I_XpZ rho_psim Vx Vp" using assms by simp
    show "{Re x |x. x \<in> spectrum X_I} \<subseteq> {- 1, 1}" using X_I_spectrum by simp
    show "{Re x |x. x \<in> spectrum X_I} \<noteq> {}" using spectrum_ne X_I_hermitian \<open>X_I \<in> fc_mats\<close> by auto
  qed
  show "AE w in M. \<bar>qt_expect Z_I Vz w\<bar> \<le> 1" unfolding qt_expect_def
  proof (rule spectrum_abs_1_weighted_suml)
    show "Z_I \<in> fc_mats" using Z_I_carrier fc_mats_carrier dim_eq dim4 by simp
    show "hermitian Z_I" using Z_I_hermitian .
    show "lhv M Z_I I_XpZ rho_psim Vz Vp" using assms by simp
    show "{Re x |x. x \<in> spectrum Z_I} \<subseteq> {- 1, 1}" using Z_I_spectrum by simp
    show "{Re x |x. x \<in> spectrum Z_I} \<noteq> {}" using spectrum_ne Z_I_hermitian \<open>Z_I \<in> fc_mats\<close> by auto
  qed
  show "AE w in M. \<bar>qt_expect I_XpZ Vp w\<bar> \<le> 1" unfolding qt_expect_def
  proof (rule spectrum_abs_1_weighted_sumr)
    show "I_XpZ \<in> fc_mats" using I_XpZ_carrier fc_mats_carrier dim_eq dim4 by simp
    show "hermitian I_XpZ" using I_XpZ_hermitian .
    show "lhv M Z_I I_XpZ rho_psim Vz Vp" using assms by simp
    show "{Re x |x. x \<in> spectrum I_XpZ} \<subseteq> {- 1, 1}" using I_XpZ_spectrum by simp
    show "{Re x |x. x \<in> spectrum I_XpZ} \<noteq> {}" using spectrum_ne I_XpZ_hermitian \<open>I_XpZ \<in> fc_mats\<close>
      by auto
  qed
  show "AE w in M. \<bar>qt_expect I_ZmX Vm w\<bar> \<le> 1" unfolding qt_expect_def
  proof (rule spectrum_abs_1_weighted_sumr)
    show "I_ZmX \<in> fc_mats" using I_ZmX_carrier fc_mats_carrier dim_eq dim4 by simp
    show "hermitian I_ZmX" using I_ZmX_hermitian .
    show "lhv M Z_I I_ZmX rho_psim Vz Vm" using assms by simp
    show "{Re x |x. x \<in> spectrum I_ZmX} \<subseteq> {- 1, 1}" using I_ZmX_spectrum by simp
    show "{Re x |x. x \<in> spectrum I_ZmX} \<noteq> {}" using spectrum_ne I_ZmX_hermitian \<open>I_ZmX \<in> fc_mats\<close>
      by auto
  qed
  show "prob_space M" using assms by simp
  show "integrable M (\<lambda>w. qt_expect X_I Vx w * qt_expect I_ZmX Vm w)"
    using spectr_sum_integrable[of M] assms by simp
  show "integrable M (\<lambda>w. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w)"
    using spectr_sum_integrable[of M] assms by simp
  show "integrable M (\<lambda>w. qt_expect X_I Vx w * qt_expect I_XpZ Vp w)"
    using spectr_sum_integrable[of M] assms by simp
  show "integrable M (\<lambda>w. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w)"
    using spectr_sum_integrable[of M] assms by simp
qed

lemma (in bin_cpx) quantum_value:
  assumes "lhv M X_I I_XpZ rho_psim Vx Vp"
  and "lhv M Z_I I_XpZ rho_psim Vz Vp"
  and "lhv M X_I I_ZmX rho_psim Vx Vm"
  and "lhv M Z_I I_ZmX rho_psim Vz Vm"
shows "\<bar>(LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w) +
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w) +
        (LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w) -
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w)\<bar>
  = 2* sqrt 2"
proof -
  have "LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w = 1/sqrt 2"
    using X_I_ZmX_chsh[of M] assms unfolding qt_expect_def by simp
  moreover have b: "LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w = 1/sqrt 2"
    using X_I_XpZ_chsh[of M] assms unfolding qt_expect_def by simp
  moreover have c: "LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w = 1/sqrt 2"
    using Z_I_XpZ_chsh[of M] assms unfolding qt_expect_def by simp
  moreover have "LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w = -1/sqrt 2"
    using Z_I_ZmX_chsh[of M] assms unfolding qt_expect_def by simp
  ultimately have "(LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w) +
        (LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w) +
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w) -
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w) = 4/(sqrt 2)"  by simp
  also have "... = (4 * (sqrt 2))/(sqrt 2 * (sqrt 2))"
    by (metis mult_numeral_1_right real_divide_square_eq times_divide_eq_right)
  also have "... = (4 * (sqrt 2)) / 2" by simp
  also have "... = 2 * (sqrt 2)" by simp
  finally have "(LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w) +
        (LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w) +
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w) -
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w) = 2 * sqrt 2" .
  thus ?thesis by (simp add: b c)
qed

lemma (in bin_cpx) no_lhv:
  assumes "lhv M X_I I_XpZ rho_psim Vx Vp"
  and "lhv M Z_I I_XpZ rho_psim Vz Vp"
  and "lhv M X_I I_ZmX rho_psim Vx Vm"
  and "lhv M Z_I I_ZmX rho_psim Vz Vm"
shows False
proof -
  have "prob_space M" using assms unfolding lhv_def by simp
  have "2 * sqrt 2 = \<bar>(LINT w|M. qt_expect X_I Vx w * qt_expect I_ZmX Vm w) +
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_XpZ Vp w) +
        (LINT w|M. qt_expect X_I Vx w * qt_expect I_XpZ Vp w) -
        (LINT w|M. qt_expect Z_I Vz w * qt_expect I_ZmX Vm w)\<bar>"
    using assms quantum_value[of M] by simp
  also have "... \<le> 2" using chsh_upper_bound[of M] assms \<open>prob_space M\<close> by simp
  finally have "2 * sqrt 2 \<le> 2" .
  thus False by simp
qed

end


(* Title:      Modal Kleene Algebras
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Modal Kleene Algebras\<close>

text \<open>This section studies laws that relate antidomain and antirange semirings and Kleene algebra,
notably Galois connections and conjugations as those studied in~\<^cite>\<open>"MoellerStruth" and "DesharnaisStruthSCP"\<close>.\<close>

theory Modal_Kleene_Algebra
imports Range_Semiring
begin

class modal_semiring = antidomain_semiring + antirange_semiring +
  assumes domrange [simp]: "d (r x) = r x"
  and rangedom [simp]: "r (d x) = d x"

begin

text \<open>These axioms force that the domain algebra and the range algebra coincide.\<close>

lemma domrangefix: "d x = x \<longleftrightarrow> r x = x"
  by (metis domrange rangedom)

lemma box_diamond_galois_1:
assumes "d p = p" and "d q = q"
shows "\<langle>x| p \<le> q \<longleftrightarrow> p \<le> |x] q"
proof -
  have "\<langle>x| p \<le> q \<longleftrightarrow> p \<cdot> x \<le> x \<cdot> q"
    by (metis assms domrangefix local.ardual.ds.fdemodalisation2 local.ars_r_def)
  thus ?thesis
    by (metis assms fbox_demodalisation3)
qed

lemma box_diamond_galois_2:
assumes "d p = p" and "d q = q"
shows "|x\<rangle> p \<le> q \<longleftrightarrow> p \<le> [x| q"
proof -
  have "|x\<rangle> p \<le> q \<longleftrightarrow> x \<cdot> p \<le> q \<cdot> x"
    by (metis assms local.ads_d_def local.ds.fdemodalisation2)
  thus ?thesis
    by (metis assms domrangefix local.ardual.fbox_demodalisation3)
qed

lemma diamond_conjugation_var_1:
assumes "d p = p" and "d q = q"
shows "|x\<rangle> p \<le> ad q \<longleftrightarrow> \<langle>x| q \<le> ad p"
proof -
  have "|x\<rangle> p \<le> ad q \<longleftrightarrow> x \<cdot> p \<le> ad q \<cdot> x"
    by (metis assms local.ads_d_def local.ds.fdemodalisation2)
  also have "... \<longleftrightarrow> q \<cdot> x \<le> x \<cdot> ad p"
    by (metis assms local.ads_d_def local.kat_1_equiv_opp)
  finally show ?thesis
    by (metis assms box_diamond_galois_1 local.ads_d_def local.fbox_demodalisation3)
qed

lemma diamond_conjungation_aux:
assumes "d p = p" and "d q = q"
shows "\<langle>x| p \<le> ad q \<longleftrightarrow> q \<cdot> \<langle>x| p = 0"
apply standard
 apply (metis assms(2) local.a_antitone' local.a_gla local.ads_d_def)
proof -
  assume a1: "q \<cdot> \<langle>x| p = zero_class.zero"
  have "ad (ad q) = q"
    using assms(2) local.ads_d_def by fastforce
  then show "\<langle>x| p \<le> ad q"
    using a1
    by (metis a_closure' a_gla ardual.a_subid_aux1' bdia_def
      dnsz.dsg4 dpdz.dsg1 dpdz.dsg3 ds.dsr4 order.trans)
qed

lemma diamond_conjugation:
assumes "d p = p" and "d q = q"
shows "p \<cdot> |x\<rangle> q = 0 \<longleftrightarrow> q \<cdot> \<langle>x| p = 0"
proof -
  have "p \<cdot> |x\<rangle> q = 0 \<longleftrightarrow> |x\<rangle> q \<le> ad p"
    by (metis assms(1) local.a_gla local.ads_d_def local.am2 local.fdia_def)
  also have "... \<longleftrightarrow> \<langle>x| p \<le> ad q"
    by (simp add: assms diamond_conjugation_var_1)
  finally show ?thesis
    by (simp add: assms diamond_conjungation_aux)
qed

lemma box_conjugation_var_1:
assumes "d p = p" and "d q = q"
shows "ad p \<le> [x| q \<longleftrightarrow> ad q \<le> |x] p"
  by (metis assms box_diamond_galois_1 box_diamond_galois_2 diamond_conjugation_var_1 local.ads_d_def)

lemma box_diamond_cancellation_1: "d p = p \<Longrightarrow> p \<le> |x] \<langle>x| p"
  using box_diamond_galois_1 domrangefix local.ars_r_def local.bdia_def by fastforce

lemma box_diamond_cancellation_2: "d p = p \<Longrightarrow> p \<le> [x| |x\<rangle> p"
  by (metis box_diamond_galois_2 local.ads_d_def local.dpdz.domain_invol local.eq_refl local.fdia_def)

lemma box_diamond_cancellation_3: "d p = p \<Longrightarrow> |x\<rangle> [x| p \<le> p"
  using box_diamond_galois_2 domrangefix local.ardual.fdia_fbox_de_morgan_2 local.ars_r_def local.bbox_def local.bdia_def by auto

lemma box_diamond_cancellation_4: "d p = p \<Longrightarrow> \<langle>x| |x] p \<le> p"
  using box_diamond_galois_1 local.ads_d_def local.fbox_def local.fdia_def local.fdia_fbox_de_morgan_2 by auto

end

class modal_kleene_algebra = modal_semiring + kleene_algebra
begin

subclass antidomain_kleene_algebra ..

subclass antirange_kleene_algebra ..

end

end


(*  Title:      CTT/ex/Equality.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Equality reasoning by rewriting"

theory Equality
imports "../CTT"
begin

lemma split_eq: "p : Sum(A,B) \<Longrightarrow> split(p,pair) = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

lemma when_eq: "\<lbrakk>A type; B type; p : A+B\<rbrakk> \<Longrightarrow> when(p,inl,inr) = p : A + B"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*in the "rec" formulation of addition, 0+n=n *)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(y)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*the harder version, n+0=n: recursive, uses induction hypothesis*)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(z)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply hyp_rew
done

(*Associativity of addition*)
lemma "\<lbrakk>a:N; b:N; c:N\<rbrakk>
  \<Longrightarrow> rec(rec(a, b, \<lambda>x y. succ(y)), c, \<lambda>x y. succ(y)) =
    rec(a, rec(b, c, \<lambda>x y. succ(y)), \<lambda>x y. succ(y)) : N"
apply (NE a)
apply hyp_rew
done

(*Martin-Lof (1984) page 62: pairing is surjective*)
lemma "p : Sum(A,B) \<Longrightarrow> <split(p,\<lambda>x y. x), split(p,\<lambda>x y. y)> = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply (tactic {* DEPTH_SOLVE_1 (rew_tac @{context} []) *}) (*!!!!!!!*)
done

lemma "\<lbrakk>a : A; b : B\<rbrakk> \<Longrightarrow> (lam u. split(u, \<lambda>v w.<w,v>)) ` <a,b> = <b,a> : SUM x:B. A"
apply rew
done

(*a contrived, complicated simplication, requires sum-elimination also*)
lemma "(lam f. lam x. f`(f`x)) ` (lam u. split(u, \<lambda>v w.<w,v>)) =
      lam x. x  :  PROD x:(SUM y:N. N). (SUM y:N. N)"
apply (rule reduction_rls)
apply (rule_tac [3] intrL_rls)
apply (rule_tac [4] EqE)
apply (erule_tac [4] SumE)
(*order of unifiers is essential here*)
apply rew
done

end