(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Functions *}

theory Relation_Algebra_Functions
  imports Relation_Algebra_Vectors Relation_Algebra_Tests
begin

subsection {* Functions *}

text {* This section collects the most important properties of functions. Most
of them can be found in the books by Maddux and by Schmidt and Str\"ohlein. The
main material is on partial and total functions, injections, surjections,
bijections. *}

(* Perhaps this material should be reorganised so that related theorems are
grouped together ... *)

context relation_algebra
begin

definition is_p_fun :: "'a \<Rightarrow> bool"
  where "is_p_fun x \<equiv> x\<^sup>\<smile> ; x \<le> 1'"

definition is_total :: "'a \<Rightarrow> bool"
  where "is_total x \<equiv> 1' \<le> x ; x\<^sup>\<smile>"

definition is_map :: "'a \<Rightarrow> bool"
  where "is_map x \<equiv> is_p_fun x \<and> is_total x"

definition is_inj :: "'a \<Rightarrow> bool"
  where "is_inj x \<equiv> x ; x\<^sup>\<smile> \<le> 1'"

definition is_sur :: "'a \<Rightarrow> bool"
  where "is_sur x \<equiv> 1' \<le> x\<^sup>\<smile> ; x"

text {* We distinguish between partial and total bijections. As usual we call
the latter just bijections. *}

definition is_p_bij :: "'a \<Rightarrow> bool"
  where "is_p_bij x \<equiv> is_p_fun x \<and> is_inj x \<and> is_sur x"

definition is_bij :: "'a \<Rightarrow> bool"
  where "is_bij x \<equiv> is_map x \<and> is_inj x \<and> is_sur x"

text {* Our first set of lemmas relates the various concepts. *}

lemma inj_p_fun: "is_inj x \<longleftrightarrow> is_p_fun (x\<^sup>\<smile>)"
by (metis conv_invol is_inj_def is_p_fun_def)

lemma p_fun_inj: "is_p_fun x \<longleftrightarrow> is_inj (x\<^sup>\<smile>)"
by (metis conv_invol inj_p_fun)

lemma sur_total: "is_sur x \<longleftrightarrow> is_total (x\<^sup>\<smile>)"
by (metis conv_invol is_sur_def is_total_def)

lemma total_sur: "is_total x \<longleftrightarrow> is_sur (x\<^sup>\<smile>)"
by (metis conv_invol sur_total)

lemma bij_conv: "is_bij x  \<longleftrightarrow> is_bij (x\<^sup>\<smile>)"
by (metis is_bij_def inj_p_fun is_map_def p_fun_inj sur_total total_sur)

text {* Next we show that tests are partial injections. *}

lemma test_is_inj_fun: "is_test x \<Longrightarrow> (is_p_fun x \<and> is_inj x)"
by (metis is_inj_def p_fun_inj test_comp test_eq_conv is_test_def)

text {* Next we show composition properties. *}

lemma p_fun_comp:
  assumes "is_p_fun x" and "is_p_fun y"
  shows "is_p_fun (x ; y)"
proof (unfold is_p_fun_def)
  have "(x ; y)\<^sup>\<smile> ; x ; y = y\<^sup>\<smile> ; x\<^sup>\<smile> ; x ; y"
    by (metis conv_contrav mult.assoc)
  also have "... \<le> y\<^sup>\<smile> ; y"
    by (metis assms(1) is_p_fun_def mult_double_iso mult.right_neutral mult.assoc)
  finally show "(x ; y)\<^sup>\<smile> ; (x ; y) \<le> 1'"
    by (metis assms(2) order_trans is_p_fun_def mult.assoc)
qed

lemma p_fun_mult_var: "x\<^sup>\<smile> ; x \<le> 1' \<Longrightarrow> (x \<cdot> y)\<^sup>\<smile> ; (x \<cdot> y) \<le> 1'"
by (metis conv_times inf_le1 mult_isol_var order_trans)

lemma inj_comp:
  assumes "is_inj x" and "is_inj y"
  shows "is_inj (x ; y)"
by (metis assms conv_contrav inj_p_fun p_fun_comp)

lemma inj_mult_var: "x\<^sup>\<smile> ; x \<le> 1' \<Longrightarrow> (x \<cdot> y)\<^sup>\<smile> ; (x \<cdot> y) \<le> 1'"
by (metis p_fun_mult_var)

lemma total_comp:
  assumes "is_total x" and "is_total y"
  shows "is_total (x ; y)"
by (metis assms inf_top_left le_iff_inf mult.assoc mult.right_neutral one_conv ra_2 is_total_def)

lemma total_add_var: "1' \<le> x\<^sup>\<smile> ; x  \<Longrightarrow> 1' \<le> (x + y)\<^sup>\<smile> ; (x + y)"
by (metis add_ub1 conv_add mult_isol_var order_trans)

lemma sur_comp:
  assumes "is_sur x" and "is_sur y"
  shows "is_sur (x ; y)"
by (metis assms conv_contrav sur_total total_comp)

lemma sur_sum_var: "1' \<le> x\<^sup>\<smile> ; x \<Longrightarrow> 1' \<le> (x + y)\<^sup>\<smile> ; (x + y)"
by (metis total_add_var)

lemma map_comp:
  assumes "is_map x" and "is_map y"
  shows "is_map (x ; y)"
by (metis assms is_map_def p_fun_comp total_comp)

lemma bij_comp:
  assumes "is_bij x" and "is_bij y"
  shows "is_bij (x ; y)"
by (metis assms is_bij_def inj_comp map_comp sur_comp)

text {* We now show that (partial) functions, unlike relations, distribute over
meets from the left. *}

lemma p_fun_distl: "is_p_fun x \<Longrightarrow> x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
proof -
  assume "is_p_fun x"
  hence "x ; (z \<cdot> ((x\<^sup>\<smile> ; x) ; y)) \<le> x ; (z \<cdot> y)"
    by (metis is_p_fun_def inf_le1 le_infI le_infI2 mult_isol mult_isor mult_onel)
  hence  "x ; y \<cdot> x ; z \<le> x ; (z \<cdot> y)"
    by (metis inf.commute mult.assoc order_trans modular_1_var)
  thus "x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
    by (metis eq_iff inf.commute le_infI mult_subdistl)
qed

lemma map_distl: "is_map x \<Longrightarrow> x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
by (metis is_map_def p_fun_distl)

text {* Next we prove simple properties of functions which arise in equivalent
definitions of those concepts. *}

lemma p_fun_zero: "is_p_fun x \<Longrightarrow> x ; y \<cdot> x ; -y = 0"
by (metis annir inf_compl_bot p_fun_distl)

lemma total_one: "is_total x \<Longrightarrow> x ; 1 = 1"
by (metis conv_invol conv_one inf_top_left le_iff_inf mult.right_neutral one_conv ra_2 is_total_def)

lemma total_1: "is_total x \<Longrightarrow> (\<forall>y. y ; x = 0 \<longrightarrow> y = 0)"
by (metis conv_invol conv_zero inf_bot_left inf_top_left peirce total_one)

lemma surj_one: "is_sur x \<Longrightarrow> 1 ; x = 1"
by (metis conv_contrav conv_invol conv_one sur_total total_one)

lemma surj_1: "is_sur x \<Longrightarrow> (\<forall>y. x ; y = 0 \<longrightarrow> y = 0)"
by (metis comp_res_aux compl_bot_eq conv_contrav conv_one inf.commute inf_top_right surj_one)

lemma bij_is_maprop:
  assumes "is_bij x" and "is_map x"
  shows "x\<^sup>\<smile> ; x  = 1' \<and> x ; x\<^sup>\<smile> = 1'"
by (metis assms is_bij_def eq_iff is_inj_def is_map_def is_p_fun_def is_sur_def is_total_def)

text{* We now provide alternative definitions for functions. These can be found
in Schmidt and Str\"ohlein's book. *}

lemma p_fun_def_var: "is_p_fun x \<longleftrightarrow> x ; -(1') \<le> -x"
by (metis conv_galois_1 double_compl galois_aux inf.commute is_p_fun_def)

lemma total_def_var_1: "is_total x \<longleftrightarrow> x ; 1 = 1"
by (metis inf_top_right le_iff_inf one_conv total_one is_total_def)

lemma total_def_var_2: "is_total x \<longleftrightarrow> -x \<le> x ; -(1')"
by (metis total_def_var_1 distrib_left sup_compl_top mult.right_neutral galois_aux3)

lemma sur_def_var1: "is_sur x \<longleftrightarrow> 1 ; x = 1"
by (metis conv_contrav conv_one sur_total surj_one total_def_var_1)

lemma sur_def_var2: "is_sur x \<longleftrightarrow> -x \<le> -(1') ; x"
by (metis sur_total total_def_var_2 conv_compl conv_contrav conv_e conv_iso)

lemma inj_def_var1: "is_inj x \<longleftrightarrow> -(1') ; x \<le> -x"
by (metis conv_galois_2 double_compl galois_aux inf.commute is_inj_def)

lemma is_maprop: "is_map x \<longleftrightarrow> x ; -(1') = -x"
by (metis eq_iff is_map_def p_fun_def_var total_def_var_2)

text {* Finally we prove miscellaneous properties of functions. *}

lemma ss_422iii: "is_p_fun y \<Longrightarrow> (x \<cdot> z ; y\<^sup>\<smile>) ; y = x ; y \<cdot> z"
(* by (smt antisym comp_assoc inf_commute maddux_17 meet_iso mult_isol mult_oner mult_subdistr_var order_trans is_p_fun_def) *)
proof (rule antisym)
  assume "is_p_fun y"
  show "x ; y \<cdot> z \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; y"
    by (metis maddux_17)
  have "(x \<cdot> z ; y\<^sup>\<smile>) ; y \<le> x ; y \<cdot> (z ; (y\<^sup>\<smile> ; y))"
    by (metis mult_subdistr_var mult.assoc)
  also have "\<dots> \<le> x ; y \<cdot> z ; 1'"
    by (metis `is_p_fun y` inf_absorb2 inf_le1 le_infI le_infI2 mult_subdistl is_p_fun_def)
  finally show "(x \<cdot> z ; y\<^sup>\<smile>) ; y \<le> x ; y \<cdot> z"
    by (metis mult.right_neutral)
qed

lemma p_fun_compl: "is_p_fun x \<Longrightarrow> x ; -y \<le> -(x; y)"
by (metis annir galois_aux inf.commute inf_compl_bot p_fun_distl)

lemma ss_422v: "is_p_fun x \<Longrightarrow> x ; -y = x ; 1 \<cdot> -(x ; y)"
by (metis inf.commute inf_absorb2 inf_top_left maddux_23 p_fun_compl)

text {* The next property is a Galois connection. *}

lemma ss43iii: "is_map x \<longleftrightarrow> (\<forall>y. x ; -y = -(x ; y))"
by (default, metis inf_top_left is_map_def ss_422v total_one, metis is_maprop mult.right_neutral)

text {* Next we prove a lemma from Schmidt and Str\"ohlein's book and some of
its consequences. We show the proof in detail since the textbook proof uses
Tarski's rule which we omit. *}

lemma ss423: "is_map x \<Longrightarrow> y ; x \<le> z \<longleftrightarrow> y \<le> z ; x\<^sup>\<smile>"
proof
  assume "is_map x" and "y ; x \<le> z"
  hence "y \<le> y ; x ; x\<^sup>\<smile>"
    by (metis is_map_def mult_1_right mult.assoc mult_isol is_total_def)
  thus "y \<le> z ; x\<^sup>\<smile>"
    by (metis `y ; x \<le> z` mult_isor order_trans)
next
  assume "is_map x" and "y \<le> z ; x\<^sup>\<smile>"
  hence "y ; x \<le> z ; x\<^sup>\<smile> ; x"
    by (metis mult_isor)
  also have "\<dots> \<le> z ; 1'"
    by (metis `is_map x` is_map_def mult.assoc mult_isol is_p_fun_def)
  finally show "y ; x \<le> z"
    by (metis mult_1_right)
qed

lemma ss424i: "is_total x \<longleftrightarrow> (\<forall>y. -(x ; y) \<le> x ; -y)"
by (metis galois_aux3 distrib_left sup_compl_top total_def_var_1)

lemma ss434ii: "is_p_fun x \<longleftrightarrow> (\<forall>y. x ; -y \<le> -(x ; y))"
by (metis mult.right_neutral p_fun_compl p_fun_def_var)

lemma is_maprop1: "is_map x \<Longrightarrow> (y \<le> x ; z ; x\<^sup>\<smile> \<longleftrightarrow> y ; x \<le> x ; z)"
by (metis ss423)

lemma is_maprop2: "is_map x \<Longrightarrow> (y ; x \<le> x ; z \<longleftrightarrow> x\<^sup>\<smile> ; y; x \<le> z)"
by (default, metis galois_aux2 inf_commute mult.assoc schroeder_1 ss43iii, metis conv_contrav conv_invol conv_iso mult.assoc ss423)

lemma is_maprop3: "is_map x \<Longrightarrow> (x\<^sup>\<smile> ; y; x \<le> z \<longleftrightarrow> x\<^sup>\<smile> ; y \<le> z ; x\<^sup>\<smile>)"
by (metis ss423)

lemma p_fun_sur_id [simp]:
  assumes "is_p_fun x" and "is_sur x"
  shows "x\<^sup>\<smile> ; x = 1'"
by (metis assms eq_iff is_p_fun_def is_sur_def)

lemma total_inj_id [simp]:
  assumes "is_total x" and "is_inj x"
  shows "x ; x\<^sup>\<smile> = 1'"
by (metis assms conv_invol inj_p_fun p_fun_sur_id sur_total)

lemma bij_inv_1 [simp]: "is_bij x \<Longrightarrow> x ; x\<^sup>\<smile> = 1'"
by (metis bij_is_maprop is_bij_def)

lemma bij_inv_2 [simp]: "is_bij x \<Longrightarrow> x\<^sup>\<smile> ; x = 1'"
by (metis bij_is_maprop is_bij_def)

lemma bij_inv_comm: "is_bij x \<Longrightarrow> x ; x\<^sup>\<smile> = x\<^sup>\<smile> ; x"
by (metis bij_inv_1 bij_inv_2)

lemma is_bijrop: "is_bij x \<Longrightarrow> (y = x ; z \<longleftrightarrow> z = x\<^sup>\<smile> ; y)"
by (metis bij_inv_1 bij_inv_2 mult.assoc mult.left_neutral)

lemma inj_map_monomorph: "\<lbrakk>is_inj x; is_map x\<rbrakk> \<Longrightarrow> (\<forall>y z. y ; x = z ; x \<longrightarrow> y = z)"
by (metis is_map_def mult.assoc mult.right_neutral total_inj_id)

lemma sur_map_epimorph: "\<lbrakk>is_sur x; is_map x\<rbrakk> \<Longrightarrow> (\<forall>y z. x ; y = x ; z \<longrightarrow> y = z)"
by (metis eq_iff mult.assoc mult.left_neutral ss423 is_sur_def)

subsection {* Points and Rectangles *}

text {* Finally here is a section on points and rectangles. This is only a
beginning. *}

definition is_point :: "'a \<Rightarrow> bool"
  where "is_point x \<equiv> is_vector x \<and> is_inj x \<and> x \<noteq> 0"

definition is_rectangle :: "'a \<Rightarrow> bool"
  where "is_rectangle x \<equiv> x ; 1 ; x \<le> x"

lemma rectangle_eq [simp]: "is_rectangle x \<longleftrightarrow> x ; 1 ; x = x"
by (metis conv_one dedekind eq_iff inf_top_left mult.assoc one_idem_mult is_rectangle_def)

subsection {* Antidomain *}

text{* This section needs to be linked with domain semirings. We essentially
prove the antidomain semiring axioms. Then we have the abstract properties at
our disposition. *}

definition antidom :: "'a \<Rightarrow> 'a" ("a")
  where "a x = 1' \<cdot> (-(x ; 1))"

definition dom :: "'a \<Rightarrow> 'a" ("d")
  where "d x = a (a x)"

lemma antidom_test_comp [simp]: "a x = (x ; 1)\<^sup>\<dagger>"
by (metis antidom_def test_compl_def)

lemma dom_def_aux: "d x = 1' \<cdot> x ; 1"
by (metis antidom_test_comp dom_def double_compl inf_top_left mult.left_neutral one_compl ra_1 test_compl_def)

lemma dom_def_aux_var: "d x = 1' \<cdot> x ; x\<^sup>\<smile>"
by (metis dom_def_aux one_conv)

lemma antidom_dom [simp]: "a (d x) = a x"
by (metis antidom_test_comp dom_def_aux inf_top_left mult.left_neutral ra_1)

lemma dom_antidom [simp]: "d (a x) = a x"
by (metis antidom_dom dom_def)

lemma dom_verystrict: "d x = 0 \<longleftrightarrow> x = 0"
by (metis annil dom_def_aux eq_iff inf_top_left maddux_20 mult.left_neutral ra_1 zero_least)

lemma a_1 [simp]: "a x ; x = 0"
by (metis antidom_test_comp galois_aux2 maddux_20 mult.left_neutral one_compl ra_1 test_compl_def)

lemma a_2: "a (x ; y) = a (x ; d y)"
by (metis antidom_test_comp dom_def_aux inf_top_left mult.assoc mult.left_neutral ra_1)

lemma a_3 [simp]: "a x + d x = 1'"
by (metis antidom_def aux4 dom_def_aux double_compl)

lemma test_domain: "x = d x \<longleftrightarrow> x \<le> 1'"
apply default
 apply (metis dom_def_aux inf_le1)
apply (metis dom_def_aux inf.commute mult.right_neutral test_1 is_test_def)
done

text {* At this point we have all the necessary ingredients to prove that
relation algebras form Boolean domain semirings. However, we omit a formal
proof since we haven't formalized the latter. *}

lemma dom_one: "x ; 1 = d x ; 1"
by (metis dom_def_aux inf_top_left mult.left_neutral ra_1)

lemma test_dom: "is_test (d x)"
by (metis dom_def_aux inf_le1 is_test_def)

lemma p_fun_dom: "is_p_fun (d x)"
by (metis test_dom test_is_inj_fun)

lemma inj_dom: "is_inj (d x)"
by (metis test_dom test_is_inj_fun)

lemma total_alt_def: "is_total x \<longleftrightarrow> (d x) = 1'"
by (metis dom_def_aux_var le_iff_inf is_total_def)

end (* relation_algebra *)

end


theory Inductive_Demo
imports Main
begin

subsection{*Inductive definition of the even numbers*}

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc(Suc n))"

thm ev0 evSS
thm ev.intros

text{* Using the introduction rules: *}
lemma "ev (Suc(Suc(Suc(Suc 0))))"
apply(rule evSS)
apply(rule evSS)
apply(rule ev0)
done

thm evSS[OF evSS[OF ev0]]

text{* A recursive definition of evenness: *}
fun even :: "nat \<Rightarrow> bool" where
"even 0 = True" |
"even (Suc 0) = False" |
"even (Suc(Suc n)) = even n"

text{*A simple example of rule induction: *}
lemma "ev n \<Longrightarrow> even n"
apply(induction rule: ev.induct)
 apply(simp)
apply(simp)
done

text{* An induction on the computation of even: *}
lemma "even n \<Longrightarrow> ev n"
apply(induction n rule: even.induct)
  apply (simp add: ev0)
 apply simp
apply(simp add: evSS)
done

text{* No problem with termination because the premises are always smaller
than the conclusion: *}
declare ev.intros[simp,intro]

text{* A shorter proof: *}
lemma "even n \<Longrightarrow> ev n"
apply(induction n rule: even.induct)
apply(simp_all)
done

text{* The power of arith: *}
lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
apply(induction rule: ev.induct)
 apply(simp)
apply arith
done

subsection{*Inductive definition of the reflexive transitive closure *}

inductive
  star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
apply(induction rule: star.induct)
apply(assumption)
apply(rename_tac u x y)
apply(metis step)
done

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Inverse Functions\<close>

theory OrdinalInverse
imports OrdinalArith
begin

lemma (in normal) oInv_ex:
  assumes "F 0 \<le> a" shows "\<exists>q. F q \<le> a \<and> a < F (oSuc q)"
proof -
  have "a < F z \<Longrightarrow> (\<exists>q<z. F q \<le> a \<and> a < F (oSuc q))" for z
  proof (induction z rule: oLimit_induct)
    case zero
    then show ?case
      using assms by auto
  next
    case (suc x)
    then show ?case
      by (metis less_oSuc linorder_not_le order_less_trans)
  next
    case (lim f)
    then show ?case
      by (metis less_oLimitD less_oLimitI oLimit)
  qed
  then show ?thesis
    by (metis increasing oSuc_le_eq_less)
qed

lemma oInv_uniq:
  assumes "mono (F::ordinal \<Rightarrow> ordinal)" "F x \<le> a" "a < F (oSuc x)" "F y \<le> a" "a < F (oSuc y)"
  shows "x = y"
proof (cases "x<y")
  case True
  with assms show ?thesis
    by (meson dual_order.trans leD monoD oSuc_leI)
next
  case False
  with assms show ?thesis
    by (meson dual_order.strict_trans2 less_oSucE mono_strict_invE)
qed

definition
  oInv :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oInv F a = (if F 0 \<le> a then (THE x. F x \<le> a \<and> a < F (oSuc x)) else 0)"

lemma (in normal) oInv_bounds: "F 0 \<le> a \<Longrightarrow> F (oInv F a) \<le> a \<and> a < F (oSuc (oInv F a))"
  by (simp add: oInv_def) (metis (no_types, lifting) theI' mono oInv_ex oInv_uniq)

lemma (in normal) oInv_bound1:
  "F 0 \<le> a \<Longrightarrow> F (oInv F a) \<le> a"
  by (rule oInv_bounds[THEN conjunct1])

lemma (in normal) oInv_bound2: "a < F (oSuc (oInv F a))"
  by (metis cancel_less linorder_not_le oInv_bounds order.strict_trans ordinal_not_0_less)

lemma (in normal) oInv_equality: "\<lbrakk>F x \<le> a; a < F (oSuc x)\<rbrakk> \<Longrightarrow> oInv F a = x"
  by (meson mono normal.cancel_le normal_axioms oInv_bound1 oInv_bound2 oInv_uniq ordinal_0_le order_trans)

lemma (in normal) oInv_inverse: "oInv F (F x) = x"
  by (rule oInv_equality, simp_all add: cancel_less)

lemma (in normal) oInv_equality': "a = F x \<Longrightarrow> oInv F a = x"
  by (simp add: oInv_inverse)

lemma (in normal) oInv_eq_0: "a \<le> F 0 \<Longrightarrow> oInv F a = 0"
  by (metis nle_le oInv_def oInv_equality')

lemma (in normal) oInv_less: "\<lbrakk>F 0 \<le> a; a < F z\<rbrakk> \<Longrightarrow> oInv F a < z"
  using cancel_less oInv_bound1 by fastforce

lemma (in normal) le_oInv: "F z \<le> a \<Longrightarrow> z \<le> oInv F a"
  by (metis cancel_le dual_order.trans le_oSucE linorder_not_less oInv_bound2 order_le_less)

lemma (in normal) less_oInvD: "x < oInv F a \<Longrightarrow> F (oSuc x) \<le> a"
  by (metis (no_types) linorder_not_le nle_le oInv_eq_0 oInv_less oSuc_leI ordinal_0_le)

lemma (in normal) oInv_le: "a < F (oSuc x) \<Longrightarrow> oInv F a \<le> x"
  by (metis leD less_oInvD nle_le order_le_less)

lemma (in normal) mono_oInv: "mono (oInv F)"
proof
  fix x y :: ordinal
  assume "x \<le> y"
  show "oInv F x \<le> oInv F y"
  proof (rule linorder_le_cases [of x "F 0"])
    assume "x \<le> F 0" then show ?thesis by (simp add: oInv_eq_0)
  next
    assume "F 0 \<le> x" show ?thesis
      by (rule le_oInv, simp only: \<open>x \<le> y\<close> \<open>F 0 \<le> x\<close> order_trans [OF oInv_bound1])
  qed
qed

lemma (in normal) oInv_decreasing: "F 0 \<le> x \<Longrightarrow> oInv F x \<le> x"
  by (meson dual_order.trans increasing oInv_bound1)

subsection \<open>Division\<close>

instantiation ordinal :: modulo
begin

definition
  div_ordinal_def:
   "x div y = (if 0 < y then oInv ((*) y) x else 0)"

definition
  mod_ordinal_def:
   "x mod y = ((x::ordinal) - y * (x div y))"

instance ..

end

lemma ordinal_divI: "\<lbrakk>x = y * q + r; r < y\<rbrakk> \<Longrightarrow> x div y = (q::ordinal)"
  using div_ordinal_def normal.oInv_equality normal_times by auto

lemma ordinal_times_div_le: "y * (x div y) \<le> (x::ordinal)"
  by (simp add: div_ordinal_def normal.oInv_bound1 normal_times)

lemma ordinal_less_times_div_plus: "0 < y \<Longrightarrow> x < y * (x div y) + (y::ordinal)"
  by (metis div_ordinal_def normal.oInv_bound2 normal_times ordinal_times_oSuc)

lemma ordinal_modI: "\<lbrakk>x = y * q + r; r < y\<rbrakk> \<Longrightarrow> x mod y = (r::ordinal)"
  by (simp add: mod_ordinal_def ordinal_divI)

lemma ordinal_mod_less: "0 < y \<Longrightarrow> x mod y < (y::ordinal)"
  by (simp add: mod_ordinal_def ordinal_less_times_div_plus ordinal_times_div_le)

lemma ordinal_div_plus_mod: "y * (x div y) + (x mod y) = (x::ordinal)"
  by (simp add: mod_ordinal_def ordinal_times_div_le)

lemma ordinal_div_less: "x < y * z \<Longrightarrow> x div y < (z::ordinal)"
  using div_ordinal_def normal.oInv_less normal_times by auto

lemma ordinal_le_div: "\<lbrakk>0 < y; y * z \<le> x\<rbrakk> \<Longrightarrow> (z::ordinal) \<le> x div y"
  by (simp add: div_ordinal_def normal.le_oInv normal_times)

lemma ordinal_div_monoL: "x \<le> x' \<Longrightarrow> x div y \<le> x' div (y::ordinal)"
  by (erule monoD[OF ordinal_mono_div])

lemma ordinal_div_decreasing: "(x::ordinal) div y \<le> x"
  by (simp add: div_ordinal_def normal.oInv_decreasing normal_times)

lemma ordinal_div_0: "x div 0 = (0::ordinal)"
  by (simp add: div_ordinal_def)

lemma ordinal_mod_0: "x mod 0 = (x::ordinal)"
  by (simp add: mod_ordinal_def)

subsection \<open>Derived properties of division\<close>

lemma ordinal_div_1 [simp]: "x div oSuc 0 = x"
  using ordinal_divI by force

lemma ordinal_mod_1 [simp]: "x mod oSuc 0 = 0"
  by (simp add: mod_ordinal_def)

lemma ordinal_div_self [simp]: "0 < x \<Longrightarrow> x div x = (1::ordinal)"
  by (metis ordinal_divI ordinal_one_def ordinal_plus_0 ordinal_times_1)

lemma ordinal_mod_self [simp]: "x mod x = (0::ordinal)"
  by (metis ordinal_modI ordinal_mod_0 ordinal_neq_0 ordinal_plus_0 ordinal_times_1)

lemma ordinal_div_greater [simp]: "x < y \<Longrightarrow> x div y = (0::ordinal)"
  by (simp add: ordinal_divI)

lemma ordinal_mod_greater [simp]: "x < y \<Longrightarrow> x mod y = (x::ordinal)"
  by (simp add: mod_ordinal_def)

lemma ordinal_0_div [simp]: "0 div x = (0::ordinal)"
  by (metis div_ordinal_def ordinal_div_greater)

lemma ordinal_0_mod [simp]: "0 mod x = (0::ordinal)"
  by (simp add: mod_ordinal_def)

lemma ordinal_1_dvd [simp]: "oSuc 0 dvd x"
  by (simp add: dvdI)

lemma ordinal_dvd_mod: "y dvd x = (x mod y = (0::ordinal))"
  by (metis dvd_def ordinal_0_times ordinal_div_plus_mod ordinal_modI ordinal_mod_0 ordinal_neq_0 ordinal_plus_0)

lemma ordinal_dvd_times_div: "y dvd x \<Longrightarrow> y * (x div y) = (x::ordinal)"
  by (metis ordinal_div_plus_mod ordinal_dvd_mod ordinal_plus_0)

lemma ordinal_dvd_oLimit:
  assumes "\<forall>n. x dvd f n" shows "x dvd oLimit f"
proof
  show "oLimit f = x * oLimit (\<lambda>n. f n div x)"
    using assms by (simp add: ordinal_dvd_times_div)
qed

subsection \<open>Logarithms\<close>

definition
  oLog :: "ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oLog b = (\<lambda>x. if 1 < b then oInv ((**) b) x else 0)"

lemma ordinal_oLogI:
  assumes "b ** y \<le> x" "x < b ** y * b" shows "oLog b x = y"
proof (cases "1 < b")
  case True
  then show ?thesis
    by (simp add: assms normal.oInv_equality normal_exp oLog_def)
qed (use assms linorder_neq_iff in fastforce)

lemma ordinal_exp_oLog_le: "\<lbrakk>0 < x; oSuc 0 < b\<rbrakk> \<Longrightarrow> b ** (oLog b x) \<le> x"
  by (simp add: normal.oInv_bound1 normal_exp oLog_def oSuc_leI)

lemma ordinal_less_exp_oLog: "oSuc 0 < b \<Longrightarrow> x < b ** (oLog b x) * b"
  by (metis normal.oInv_bound2 normal_exp oLog_def ordinal_exp_oSuc ordinal_one_def)

lemma ordinal_oLog_less: "\<lbrakk>0 < x; oSuc 0 < b; x < b ** y\<rbrakk> \<Longrightarrow> oLog b x < y"
  by (simp add: normal.oInv_less normal_exp oLog_def oSuc_leI)

lemma ordinal_le_oLog:
  "\<lbrakk>oSuc 0 < b; b ** y \<le> x\<rbrakk> \<Longrightarrow> y \<le> oLog b x"
  by (simp add: oLog_def normal.le_oInv[OF normal_exp])

lemma ordinal_oLogI2:
  assumes "oSuc 0 < b" "x = b ** y * q + r" "0 < q" "q < b" "r < b ** y"
  shows "oLog b x = y"
proof (rule ordinal_oLogI)
  show "b ** y \<le> x"
    using assms by (metis dual_order.trans ordinal_le_plusR ordinal_le_timesR)
  show "x < b ** y * b"
    using assms
    by (metis leD leI order_less_trans ordinal_divI ordinal_exp_not_0 ordinal_le_div)
qed

lemma ordinal_div_exp_oLog_less: "oSuc 0 < b \<Longrightarrow> x div (b ** oLog b x) < b"
  by (simp add: ordinal_div_less ordinal_less_exp_oLog)

lemma ordinal_oLog_base_0: "oLog 0 x = 0"
  by (simp add: oLog_def)

lemma ordinal_oLog_base_1: "oLog (oSuc 0) x = 0"
  by (simp add: oLog_def)

lemma ordinal_oLog_exp: "oSuc 0 < b \<Longrightarrow> oLog b (b ** x) = x"
  by (simp add: oLog_def normal.oInv_inverse[OF normal_exp])

lemma ordinal_oLog_self: "oSuc 0 < b \<Longrightarrow> oLog b b = oSuc 0"
  by (metis ordinal_exp_1 ordinal_oLog_exp)

lemma ordinal_mono_oLog: "mono (oLog b)"
  by (simp add: monoD monoI normal.mono_oInv normal_exp oLog_def)

lemma ordinal_oLog_monoR: "x \<le> y \<Longrightarrow> oLog b x \<le> oLog b y"
  by (erule monoD[OF ordinal_mono_oLog])

lemma ordinal_oLog_decreasing: "oLog b x \<le> x"
  by (metis normal.increasing normal_exp oLog_def ordinal_0_le ordinal_oLog_exp ordinal_oLog_monoR ordinal_one_def)

end


section \<open>Tensor products (finite dimensional)\<close>

theory Finite_Tensor_Product
  imports Complex_Bounded_Operators.Complex_L2 Misc
begin

declare cblinfun.scaleC_right[simp]

unbundle cblinfun_notation
no_notation m_inv ("inv\<index> _" [81] 80)

lift_definition tensor_ell2 :: \<open>'a::finite ell2 \<Rightarrow> 'b::finite ell2 \<Rightarrow> ('a\<times>'b) ell2\<close> (infixr "\<otimes>\<^sub>s" 70) is
  \<open>\<lambda>\<psi> \<phi> (i,j). \<psi> i * \<phi> j\<close>
  by simp

lemma tensor_ell2_add2: \<open>tensor_ell2 a (b + c) = tensor_ell2 a b + tensor_ell2 a c\<close>
  apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
  by (meson algebra_simps)

lemma tensor_ell2_add1: \<open>tensor_ell2 (a + b) c = tensor_ell2 a c + tensor_ell2 b c\<close>
  apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
  by (simp add: vector_space_over_itself.scale_left_distrib)

lemma tensor_ell2_scaleC2: \<open>tensor_ell2 a (c *\<^sub>C b) = c *\<^sub>C tensor_ell2 a b\<close>
  apply transfer apply (rule ext) by (auto simp: case_prod_beta)

lemma tensor_ell2_scaleC1: \<open>tensor_ell2 (c *\<^sub>C a) b = c *\<^sub>C tensor_ell2 a b\<close>
  apply transfer apply (rule ext) by (auto simp: case_prod_beta)

lemma tensor_ell2_inner_prod[simp]: \<open>\<langle>tensor_ell2 a b, tensor_ell2 c d\<rangle> = \<langle>a,c\<rangle> * \<langle>b,d\<rangle>\<close>
  apply transfer
  by (auto simp: case_prod_beta sum_product sum.cartesian_product mult.assoc mult.left_commute)

lemma clinear_tensor_ell21: "clinear (\<lambda>b. tensor_ell2 a b)"
  apply (rule clinearI; transfer)
   apply (auto simp: case_prod_beta)
  by (simp add: cond_case_prod_eta algebra_simps)

lemma clinear_tensor_ell22: "clinear (\<lambda>a. tensor_ell2 a b)"
  apply (rule clinearI; transfer)
   apply (auto simp: case_prod_beta)
  by (simp add: case_prod_beta' algebra_simps)

lemma tensor_ell2_ket[simp]: "tensor_ell2 (ket i) (ket j) = ket (i,j)"
  apply transfer by auto

definition tensor_op :: \<open>('a ell2, 'b::finite ell2) cblinfun \<Rightarrow> ('c ell2, 'd::finite ell2) cblinfun
      \<Rightarrow> (('a\<times>'c) ell2, ('b\<times>'d) ell2) cblinfun\<close> (infixr "\<otimes>\<^sub>o" 70) where
  \<open>tensor_op M N = (SOME P. \<forall>a c. P *\<^sub>V (ket (a,c))
      = tensor_ell2 (M *\<^sub>V ket a) (N *\<^sub>V ket c))\<close>

lemma tensor_op_ket:
  fixes a :: \<open>'a::finite\<close> and b :: \<open>'b\<close> and c :: \<open>'c::finite\<close> and d :: \<open>'d\<close>
  shows \<open>tensor_op M N *\<^sub>V (ket (a,c)) = tensor_ell2 (M *\<^sub>V ket a) (N *\<^sub>V ket c)\<close>
proof -
  define S :: \<open>('a\<times>'c) ell2 set\<close> where "S = ket ` UNIV"
  define \<phi> where \<open>\<phi> = (\<lambda>(a,c). tensor_ell2 (M *\<^sub>V ket a) (N *\<^sub>V ket c))\<close>
  define \<phi>' where \<open>\<phi>' = \<phi> \<circ> inv ket\<close>

  have def: \<open>tensor_op M N = (SOME P. \<forall>a c. P *\<^sub>V (ket (a,c)) = \<phi> (a,c))\<close>
    unfolding tensor_op_def \<phi>_def by auto

  have \<open>cindependent S\<close>
    using S_def cindependent_ket by blast
  moreover have \<open>cspan S = UNIV\<close>
    using S_def cspan_range_ket_finite by blast
  ultimately have "cblinfun_extension_exists S \<phi>'"
    by (rule cblinfun_extension_exists_finite_dim)
  then have "\<exists>P. \<forall>x\<in>S. P *\<^sub>V x = \<phi>' x"
    unfolding cblinfun_extension_exists_def by auto
  then have ex: \<open>\<exists>P. \<forall>a c. P *\<^sub>V ket (a,c) = \<phi> (a,c)\<close>
    by (metis S_def \<phi>'_def comp_eq_dest_lhs inj_ket inv_f_f rangeI)

  then have \<open>tensor_op M N *\<^sub>V (ket (a,c)) = \<phi> (a,c)\<close>
    unfolding def apply (rule someI2_ex[where P=\<open>\<lambda>P. \<forall>a c. P *\<^sub>V (ket (a,c)) = \<phi> (a,c)\<close>])
    by auto
  then show ?thesis
    unfolding \<phi>_def by auto
qed

lemma tensor_op_ell2: "tensor_op A B *\<^sub>V tensor_ell2 \<psi> \<phi> = tensor_ell2 (A *\<^sub>V \<psi>) (B *\<^sub>V \<phi>)"
proof -
  have 1: \<open>clinear (\<lambda>a. tensor_op A B *\<^sub>V tensor_ell2 a (ket b))\<close> for b
    by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
  have 2: \<open>clinear (\<lambda>a. tensor_ell2 (A *\<^sub>V a) (B *\<^sub>V ket b))\<close> for b
    by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
  have 3: \<open>clinear (\<lambda>a. tensor_op A B *\<^sub>V tensor_ell2 \<psi> a)\<close>
    by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)
  have 4: \<open>clinear (\<lambda>a. tensor_ell2 (A *\<^sub>V \<psi>) (B *\<^sub>V a))\<close>
    by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)

  have eq_ket_ket: \<open>tensor_op A B *\<^sub>V tensor_ell2 (ket a) (ket b) = tensor_ell2 (A *\<^sub>V ket a) (B *\<^sub>V ket b)\<close> for a b
    by (simp add: tensor_op_ket)
  have eq_ket: \<open>tensor_op A B *\<^sub>V tensor_ell2 \<psi> (ket b) = tensor_ell2 (A *\<^sub>V \<psi>) (B *\<^sub>V ket b)\<close> for b
    apply (rule fun_cong[where x=\<psi>])
    using 1 2 eq_ket_ket by (rule clinear_equal_ket)
  show ?thesis
    apply (rule fun_cong[where x=\<phi>])
    using 3 4 eq_ket by (rule clinear_equal_ket)
qed

lemma comp_tensor_op: "(tensor_op a b) o\<^sub>C\<^sub>L (tensor_op c d) = tensor_op (a o\<^sub>C\<^sub>L c) (b o\<^sub>C\<^sub>L d)"
  for a :: "'e::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2" and b :: "'f::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2" and
      c :: "'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'e ell2" and d :: "'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'f ell2"
  apply (rule equal_ket)
  apply (rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun_apply_cblinfun_compose)

lemma tensor_op_cbilinear: \<open>cbilinear (tensor_op :: 'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2
                                                 \<Rightarrow> 'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2 \<Rightarrow> _)\<close>
proof -
  have \<open>clinear (\<lambda>b::'c ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd ell2. tensor_op a b)\<close> for a :: \<open>'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close>
    apply (rule clinearI)
     apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
     apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add2)
    apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
    by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC2 tensor_op_ket)

  moreover have \<open>clinear (\<lambda>a::'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2. tensor_op a b)\<close> for b :: \<open>'c ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd ell2\<close>
    apply (rule clinearI)
     apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
     apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add1)
    apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
    by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC1 tensor_op_ket)

  ultimately show ?thesis
    unfolding cbilinear_def by auto
qed

lemma tensor_butter: \<open>tensor_op (butterket i j) (butterket k l) = butterket (i,k) (j,l)\<close>
  for i :: "_" and j :: "_::finite" and k :: "_" and l :: "_::finite"
  apply (rule equal_ket, rename_tac x, case_tac x)
  apply (auto simp flip: tensor_ell2_ket simp: cblinfun_apply_cblinfun_compose tensor_op_ell2 butterfly_def)
  by (auto simp: tensor_ell2_scaleC1 tensor_ell2_scaleC2)

lemma cspan_tensor_op: \<open>cspan {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True} = UNIV\<close>
  unfolding tensor_butter
  apply (subst cspan_butterfly_ket[symmetric])
  by (metis surj_pair)

lemma cindependent_tensor_op: \<open>cindependent {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True}\<close>
  unfolding tensor_butter
  using cindependent_butterfly_ket
  by (smt (z3) Collect_mono_iff complex_vector.independent_mono)

lemma tensor_extensionality:
  fixes F G :: \<open>((('a::finite \<times> 'b::finite) ell2) \<Rightarrow>\<^sub>C\<^sub>L (('c::finite \<times> 'd::finite) ell2)) \<Rightarrow> 'e::complex_vector\<close>
  assumes [simp]: "clinear F" "clinear G"
  assumes tensor_eq: "(\<And>a b. F (tensor_op a b) = G (tensor_op a b))"
  shows "F = G"
proof (rule ext, rule complex_vector.linear_eq_on_span[where f=F and g=G])
  show \<open>clinear F\<close> and \<open>clinear G\<close>
    using assms by (simp_all add: cbilinear_def)
  show \<open>x \<in> cspan  {tensor_op (butterket i j) (butterket k l)| i j k l. True}\<close>
    for x :: \<open>('a \<times> 'b) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('c \<times> 'd) ell2\<close>
    using cspan_tensor_op by auto
  show \<open>F x = G x\<close> if \<open>x \<in> {tensor_op (butterket i j) (butterket k l) |i j k l. True}\<close> for x
    using that by (auto simp: tensor_eq)
qed

lemma tensor_id[simp]: \<open>tensor_op id_cblinfun id_cblinfun = id_cblinfun\<close>
  apply (rule equal_ket, rename_tac x, case_tac x)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2)

lemma tensor_op_adjoint: \<open>(tensor_op a b)* = tensor_op (a*) (b*)\<close>
  apply (rule cinner_ket_adjointI[symmetric])
  apply (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)
  by (simp add: cinner_adj_left)

lemma tensor_butterfly[simp]: "tensor_op (butterfly \<psi> \<psi>') (butterfly \<phi> \<phi>') = butterfly (tensor_ell2 \<psi> \<phi>) (tensor_ell2 \<psi>' \<phi>')"
  apply (rule equal_ket, rename_tac x, case_tac x)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2 butterfly_def
      cblinfun_apply_cblinfun_compose tensor_ell2_scaleC1 tensor_ell2_scaleC2)

definition tensor_lift :: \<open>(('a1::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a2::finite ell2) \<Rightarrow> ('b1::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b2::finite ell2) \<Rightarrow> 'c)
                        \<Rightarrow> ((('a1\<times>'b1) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('a2\<times>'b2) ell2) \<Rightarrow> 'c::complex_vector)\<close> where
  "tensor_lift F2 = (SOME G. clinear G \<and> (\<forall>a b. G (tensor_op a b) = F2 a b))"

lemma
  fixes F2 :: "'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2
            \<Rightarrow> 'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2
            \<Rightarrow> 'e::complex_normed_vector"
  assumes "cbilinear F2"
  shows tensor_lift_clinear: "clinear (tensor_lift F2)"
    and tensor_lift_correct:  \<open>(\<lambda>a b. tensor_lift F2 (tensor_op a b)) = F2\<close>
proof -
  define F2' t4 \<phi> where
    \<open>F2' = tensor_lift F2\<close> and
    \<open>t4 = (\<lambda>(i,j,k,l). tensor_op (butterket i j) (butterket k l))\<close> and
    \<open>\<phi> m = (let (i,j,k,l) = inv t4 m in F2 (butterket i j) (butterket k l))\<close> for m
  have t4inj: "x = y" if "t4 x = t4 y" for x y
  proof (rule ccontr)
    obtain i  j  k  l  where x: "x = (i,j,k,l)" by (meson prod_cases4)
    obtain i' j' k' l' where y: "y = (i',j',k',l')" by (meson prod_cases4)
    have 1: "bra (i,k) *\<^sub>V t4 x *\<^sub>V ket (j,l) = 1"
      by (auto simp: t4_def x tensor_op_ell2 butterfly_def cinner_ket simp flip: tensor_ell2_ket)
    assume \<open>x \<noteq> y\<close>
    then have 2: "bra (i,k) *\<^sub>V t4 y *\<^sub>V ket (j,l) = 0"
      by (auto simp: t4_def x y tensor_op_ell2 butterfly_def cblinfun_apply_cblinfun_compose cinner_ket
               simp flip: tensor_ell2_ket)
    from 1 2 that
    show False
      by auto
  qed
  have \<open>\<phi> (tensor_op (butterket i j) (butterket k l)) = F2 (butterket i j) (butterket k l)\<close> for i j k l
    apply (subst asm_rl[of \<open>tensor_op (butterket i j) (butterket k l) = t4 (i,j,k,l)\<close>])
     apply (simp add: t4_def)
    by (auto simp add: injI t4inj inv_f_f \<phi>_def)

  have *: \<open>range t4 = {tensor_op (butterket i j) (butterket k l) |i j k l. True}\<close>
    apply (auto simp: case_prod_beta t4_def)
    using image_iff by fastforce

  have "cblinfun_extension_exists (range t4) \<phi>"
    thm cblinfun_extension_exists_finite_dim[where \<phi>=\<phi>]
    apply (rule cblinfun_extension_exists_finite_dim)
     apply auto unfolding *
    using cindependent_tensor_op
    using cspan_tensor_op
    by auto

  then obtain G where G: \<open>G *\<^sub>V (t4 (i,j,k,l)) = F2 (butterket i j) (butterket k l)\<close> for i j k l
    apply atomize_elim
    unfolding cblinfun_extension_exists_def
    apply auto
    by (metis (no_types, lifting) t4inj \<phi>_def f_inv_into_f rangeI split_conv)

  have *: \<open>G *\<^sub>V tensor_op (butterket i j) (butterket k l) = F2 (butterket i j) (butterket k l)\<close> for i j k l
    using G by (auto simp: t4_def)
  have *: \<open>G *\<^sub>V tensor_op a (butterket k l) = F2 a (butterket k l)\<close> for a k l
    apply (rule complex_vector.linear_eq_on_span[where g=\<open>\<lambda>a. F2 a _\<close> and B=\<open>{butterket k l|k l. True}\<close>])
    unfolding cspan_butterfly_ket
    using * apply (auto intro!: clinear_compose[unfolded o_def, where f=\<open>\<lambda>a. tensor_op a _\<close> and g=\<open>(*\<^sub>V) G\<close>])
     apply (metis cbilinear_def tensor_op_cbilinear)
    using assms unfolding cbilinear_def by blast
  have G_F2: \<open>G *\<^sub>V tensor_op a b = F2 a b\<close> for a b
    apply (rule complex_vector.linear_eq_on_span[where g=\<open>F2 a\<close> and B=\<open>{butterket k l|k l. True}\<close>])
    unfolding cspan_butterfly_ket
    using * apply (auto simp: cblinfun.add_right clinearI
                        intro!: clinear_compose[unfolded o_def, where f=\<open>tensor_op a\<close> and g=\<open>(*\<^sub>V) G\<close>])
    apply (meson cbilinear_def tensor_op_cbilinear)
    using assms unfolding cbilinear_def by blast

  have \<open>clinear F2' \<and> (\<forall>a b. F2' (tensor_op a b) = F2 a b)\<close>
    unfolding F2'_def tensor_lift_def
    apply (rule someI[where x=\<open>(*\<^sub>V) G\<close> and P=\<open>\<lambda>G. clinear G \<and> (\<forall>a b. G (tensor_op a b) = F2 a b)\<close>])
    using G_F2 by (simp add: cblinfun.add_right clinearI)

  then show \<open>clinear F2'\<close> and \<open>(\<lambda>a b. tensor_lift F2 (tensor_op a b)) = F2\<close>
    unfolding F2'_def by auto
qed

lift_definition assoc_ell20 :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) ell2 \<Rightarrow> ('a\<times>('b\<times>'c)) ell2\<close> is
  \<open>\<lambda>f (a,(b,c)). f ((a,b),c)\<close>
  by auto

lift_definition assoc_ell20' :: \<open>('a::finite\<times>('b::finite\<times>'c::finite)) ell2 \<Rightarrow> (('a\<times>'b)\<times>'c) ell2\<close> is
  \<open>\<lambda>f ((a,b),c). f (a,(b,c))\<close>
  by auto

lift_definition assoc_ell2 :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('a\<times>('b\<times>'c)) ell2\<close>
  is assoc_ell20
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lift_definition assoc_ell2' :: \<open>('a::finite\<times>('b::finite\<times>'c::finite)) ell2 \<Rightarrow>\<^sub>C\<^sub>L (('a\<times>'b)\<times>'c) ell2\<close> is
  assoc_ell20'
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lemma assoc_ell2_tensor: \<open>assoc_ell2 *\<^sub>V tensor_ell2 (tensor_ell2 a b) c = tensor_ell2 a (tensor_ell2 b c)\<close>
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell22)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
  unfolding assoc_ell2.rep_eq
  apply transfer
  by auto

lemma assoc_ell2'_tensor: \<open>assoc_ell2' *\<^sub>V tensor_ell2 a (tensor_ell2 b c) = tensor_ell2 (tensor_ell2 a b) c\<close>
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
  unfolding assoc_ell2'.rep_eq
  apply transfer
  by auto

lemma adjoint_assoc_ell2[simp]: \<open>assoc_ell2* = assoc_ell2'\<close>
proof (rule adjoint_eqI[symmetric])
  have [simp]: \<open>clinear (cinner (assoc_ell2' *\<^sub>V x))\<close> for x :: \<open>('a \<times> 'b \<times> 'c) ell2\<close>
    by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
  have [simp]: \<open>clinear (\<lambda>a. \<langle>x, assoc_ell2 *\<^sub>V a\<rangle>)\<close> for x :: \<open>('a \<times> 'b \<times> 'c) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_right clinearI)
  have [simp]: \<open>antilinear (\<lambda>a. \<langle>a, y\<rangle>)\<close> for y :: \<open>('a \<times> 'b \<times> 'c) ell2\<close>
    using bounded_antilinear_cinner_left bounded_antilinear_def by blast
  have [simp]: \<open>antilinear (\<lambda>a. \<langle>assoc_ell2' *\<^sub>V a, y\<rangle>)\<close> for y :: \<open>(('a \<times> 'b) \<times> 'c) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have \<open>\<langle>assoc_ell2' *\<^sub>V (ket x), ket y\<rangle> = \<langle>ket x, assoc_ell2 *\<^sub>V ket y\<rangle>\<close> for x :: \<open>'a \<times> 'b \<times> 'c\<close> and y
    apply (cases x, cases y)
    by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor)
  then have \<open>\<langle>assoc_ell2' *\<^sub>V (ket x), y\<rangle> = \<langle>ket x, assoc_ell2 *\<^sub>V y\<rangle>\<close> for x :: \<open>'a \<times> 'b \<times> 'c\<close> and y
    by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
  then show \<open>\<langle>assoc_ell2' *\<^sub>V x, y\<rangle> = \<langle>x, assoc_ell2 *\<^sub>V y\<rangle>\<close> for x :: \<open>('a \<times> 'b \<times> 'c) ell2\<close> and y
    by (rule antilinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
qed

lemma adjoint_assoc_ell2'[simp]: \<open>assoc_ell2'* = assoc_ell2\<close>
  by (simp flip: adjoint_assoc_ell2)

lift_definition swap_ell20 :: \<open>('a::finite\<times>'b::finite) ell2 \<Rightarrow> ('b\<times>'a) ell2\<close> is
  \<open>\<lambda>f (a,b). f (b,a)\<close>
  by auto

lift_definition swap_ell2 :: \<open>('a::finite\<times>'b::finite) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('b\<times>'a) ell2\<close>
  is swap_ell20
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lemma swap_ell2_tensor[simp]: \<open>swap_ell2 *\<^sub>V tensor_ell2 a b = tensor_ell2 b a\<close>
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell21)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  unfolding swap_ell2.rep_eq
  apply transfer
  by auto

lemma adjoint_swap_ell2[simp]: \<open>swap_ell2* = swap_ell2\<close>
proof (rule adjoint_eqI[symmetric])
  have [simp]: \<open>clinear (cinner (swap_ell2 *\<^sub>V x))\<close> for x :: \<open>('a \<times> 'b) ell2\<close>
    by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
  have [simp]: \<open>clinear (\<lambda>a. \<langle>x, swap_ell2 *\<^sub>V a\<rangle>)\<close> for x :: \<open>('a \<times> 'b) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_right clinearI)
  have [simp]: \<open>antilinear (\<lambda>a. \<langle>a, y\<rangle>)\<close> for y :: \<open>('a \<times> 'b) ell2\<close>
    using bounded_antilinear_cinner_left bounded_antilinear_def by blast
  have [simp]: \<open>antilinear (\<lambda>a. \<langle>swap_ell2 *\<^sub>V a, y\<rangle>)\<close> for y :: \<open>('b \<times> 'a) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have \<open>\<langle>swap_ell2 *\<^sub>V (ket x), ket y\<rangle> = \<langle>ket x, swap_ell2 *\<^sub>V ket y\<rangle>\<close> for x :: \<open>'a \<times> 'b\<close> and y
    apply (cases x, cases y)
    by (simp flip: tensor_ell2_ket add: swap_ell2_tensor)
  then have \<open>\<langle>swap_ell2 *\<^sub>V (ket x), y\<rangle> = \<langle>ket x, swap_ell2 *\<^sub>V y\<rangle>\<close> for x :: \<open>'a \<times> 'b\<close> and y
    by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
  then show \<open>\<langle>swap_ell2 *\<^sub>V x, y\<rangle> = \<langle>x, swap_ell2 *\<^sub>V y\<rangle>\<close> for x :: \<open>('a \<times> 'b) ell2\<close> and y
    apply (rule antilinear_equal_ket[THEN fun_cong, rotated 2])
    by simp_all
qed

lemma tensor_ell2_extensionality:
  assumes "(\<And>s t. a *\<^sub>V (s \<otimes>\<^sub>s t) = b *\<^sub>V (s \<otimes>\<^sub>s t))"
  shows "a = b"
  apply (rule equal_ket, case_tac x, hypsubst_thin)
  by (simp add: assms flip: tensor_ell2_ket)

lemma assoc_ell2'_assoc_ell2[simp]: \<open>assoc_ell2' o\<^sub>C\<^sub>L assoc_ell2 = id_cblinfun\<close>
  by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)

lemma assoc_ell2_assoc_ell2'[simp]: \<open>assoc_ell2 o\<^sub>C\<^sub>L assoc_ell2' = id_cblinfun\<close>
  by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)

lemma unitary_assoc_ell2[simp]: "unitary assoc_ell2"
  unfolding unitary_def by auto

lemma unitary_assoc_ell2'[simp]: "unitary assoc_ell2'"
  unfolding unitary_def by auto

lemma tensor_op_left_add: \<open>(x + y) \<otimes>\<^sub>o b = x \<otimes>\<^sub>o b + y \<otimes>\<^sub>o b\<close>
  for x y :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (simp add: plus_cblinfun.rep_eq tensor_ell2_add1 tensor_op_ket)

lemma tensor_op_right_add: \<open>b \<otimes>\<^sub>o (x + y) = b \<otimes>\<^sub>o x + b \<otimes>\<^sub>o y\<close>
  for x y :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (simp add: plus_cblinfun.rep_eq tensor_ell2_add2 tensor_op_ket)

lemma tensor_op_scaleC_left: \<open>(c *\<^sub>C x) \<otimes>\<^sub>o b = c *\<^sub>C (x \<otimes>\<^sub>o b)\<close>
  for x :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC1 tensor_op_ell2)

lemma tensor_op_scaleC_right: \<open>b \<otimes>\<^sub>o (c *\<^sub>C x) = c *\<^sub>C (b \<otimes>\<^sub>o x)\<close>
  for x :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC2 tensor_op_ell2)

lemma clinear_tensor_left[simp]: \<open>clinear (\<lambda>a. a \<otimes>\<^sub>o b :: _::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L _::finite ell2)\<close>
  apply (rule clinearI)
   apply (rule tensor_op_left_add)
  by (rule tensor_op_scaleC_left)

lemma clinear_tensor_right[simp]: \<open>clinear (\<lambda>b. a \<otimes>\<^sub>o b :: _::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L _::finite ell2)\<close>
  apply (rule clinearI)
   apply (rule tensor_op_right_add)
  by (rule tensor_op_scaleC_right)

lemma tensor_ell2_nonzero: \<open>a \<otimes>\<^sub>s b \<noteq> 0\<close> if \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close>
  apply (use that in transfer)
  apply auto
  by (metis mult_eq_0_iff old.prod.case)

lemma tensor_op_nonzero:
  fixes a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2\<close> and b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  assumes \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close>
  shows \<open>a \<otimes>\<^sub>o b \<noteq> 0\<close>
proof -
  from \<open>a \<noteq> 0\<close> obtain i where i: \<open>a *\<^sub>V ket i \<noteq> 0\<close>
    by (metis cblinfun.zero_left equal_ket)
  from \<open>b \<noteq> 0\<close> obtain j where j: \<open>b *\<^sub>V ket j \<noteq> 0\<close>
    by (metis cblinfun.zero_left equal_ket)
  from i j have ijneq0: \<open>(a *\<^sub>V ket i) \<otimes>\<^sub>s (b *\<^sub>V ket j) \<noteq> 0\<close>
    by (simp add: tensor_ell2_nonzero)
  have \<open>(a *\<^sub>V ket i) \<otimes>\<^sub>s (b *\<^sub>V ket j) = (a \<otimes>\<^sub>o b) *\<^sub>V ket (i,j)\<close>
    by (simp add: tensor_op_ket)
  with ijneq0 show \<open>a \<otimes>\<^sub>o b \<noteq> 0\<close>
    by force
qed

lemma inj_tensor_ell2_left: \<open>inj (\<lambda>a::'a::finite ell2. a \<otimes>\<^sub>s b)\<close> if \<open>b \<noteq> 0\<close> for b :: \<open>'b::finite ell2\<close>
proof (rule injI, rule ccontr)
  fix x y :: \<open>'a ell2\<close>
  assume eq: \<open>x \<otimes>\<^sub>s b = y \<otimes>\<^sub>s b\<close>
  assume neq: \<open>x \<noteq> y\<close>
  define a where \<open>a = x - y\<close>
  from neq a_def have neq0: \<open>a \<noteq> 0\<close>
    by auto
  with \<open>b \<noteq> 0\<close> have \<open>a \<otimes>\<^sub>s b \<noteq> 0\<close>
    by (simp add: tensor_ell2_nonzero)
  then have \<open>x \<otimes>\<^sub>s b \<noteq> y \<otimes>\<^sub>s b\<close>
    unfolding a_def
    by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add1)
  with eq show False
    by auto
qed

lemma inj_tensor_ell2_right: \<open>inj (\<lambda>b::'b::finite ell2. a \<otimes>\<^sub>s b)\<close> if \<open>a \<noteq> 0\<close> for a :: \<open>'a::finite ell2\<close>
proof (rule injI, rule ccontr)
  fix x y :: \<open>'b ell2\<close>
  assume eq: \<open>a \<otimes>\<^sub>s x = a \<otimes>\<^sub>s y\<close>
  assume neq: \<open>x \<noteq> y\<close>
  define b where \<open>b = x - y\<close>
  from neq b_def have neq0: \<open>b \<noteq> 0\<close>
    by auto
  with \<open>a \<noteq> 0\<close> have \<open>a \<otimes>\<^sub>s b \<noteq> 0\<close>
    by (simp add: tensor_ell2_nonzero)
  then have \<open>a \<otimes>\<^sub>s x \<noteq> a \<otimes>\<^sub>s y\<close>
    unfolding b_def
    by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add2)
  with eq show False
    by auto
qed

lemma inj_tensor_left: \<open>inj (\<lambda>a::'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2. a \<otimes>\<^sub>o b)\<close> if \<open>b \<noteq> 0\<close> for b :: \<open>'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
proof (rule injI, rule ccontr)
  fix x y :: \<open>'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c ell2\<close>
  assume eq: \<open>x \<otimes>\<^sub>o b = y \<otimes>\<^sub>o b\<close>
  assume neq: \<open>x \<noteq> y\<close>
  define a where \<open>a = x - y\<close>
  from neq a_def have neq0: \<open>a \<noteq> 0\<close>
    by auto
  with \<open>b \<noteq> 0\<close> have \<open>a \<otimes>\<^sub>o b \<noteq> 0\<close>
    by (simp add: tensor_op_nonzero)
  then have \<open>x \<otimes>\<^sub>o b \<noteq> y \<otimes>\<^sub>o b\<close>
    unfolding a_def
    by (metis add_cancel_left_left diff_add_cancel tensor_op_left_add)
  with eq show False
    by auto
qed

lemma inj_tensor_right: \<open>inj (\<lambda>b::'b::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c::finite ell2. a \<otimes>\<^sub>o b)\<close> if \<open>a \<noteq> 0\<close> for a :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
proof (rule injI, rule ccontr)
  fix x y :: \<open>'b ell2 \<Rightarrow>\<^sub>C\<^sub>L 'c ell2\<close>
  assume eq: \<open>a \<otimes>\<^sub>o x = a \<otimes>\<^sub>o y\<close>
  assume neq: \<open>x \<noteq> y\<close>
  define b where \<open>b = x - y\<close>
  from neq b_def have neq0: \<open>b \<noteq> 0\<close>
    by auto
  with \<open>a \<noteq> 0\<close> have \<open>a \<otimes>\<^sub>o b \<noteq> 0\<close>
    by (simp add: tensor_op_nonzero)
  then have \<open>a \<otimes>\<^sub>o x \<noteq> a \<otimes>\<^sub>o y\<close>
    unfolding b_def
    by (metis add_cancel_left_left diff_add_cancel tensor_op_right_add)
  with eq show False
    by auto
qed

lemma tensor_ell2_almost_injective:
  assumes \<open>tensor_ell2 a b = tensor_ell2 c d\<close>
  assumes \<open>a \<noteq> 0\<close>
  shows \<open>\<exists>\<gamma>. b = \<gamma> *\<^sub>C d\<close>
proof -
  from \<open>a \<noteq> 0\<close> obtain i where i: \<open>cinner (ket i) a \<noteq> 0\<close>
    by (metis cinner_eq_zero_iff cinner_ket_left ell2_pointwise_ortho)
  have \<open>cinner (ket i \<otimes>\<^sub>s ket j) (a \<otimes>\<^sub>s b) = cinner (ket i \<otimes>\<^sub>s ket j) (c \<otimes>\<^sub>s d)\<close> for j
    using assms by simp
  then have eq2: \<open>(cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) c) * (cinner (ket j) d)\<close> for j
    by (metis tensor_ell2_inner_prod)
  then obtain \<gamma> where \<open>cinner (ket i) c = \<gamma> * cinner (ket i) a\<close>
    by (metis i eq_divide_eq)
  with eq2 have \<open>(cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) a) * (\<gamma> * cinner (ket j) d)\<close> for j
    by simp
  then have \<open>cinner (ket j) b = cinner (ket j) (\<gamma> *\<^sub>C d)\<close> for j
    using i by force
  then have \<open>b = \<gamma> *\<^sub>C d\<close>
    by (simp add: cinner_ket_eqI)
  then show ?thesis
    by auto
qed

lemma tensor_op_almost_injective:
  fixes a c :: \<open>'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2\<close>
    and b d :: \<open>'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2\<close>
  assumes \<open>tensor_op a b = tensor_op c d\<close>
  assumes \<open>a \<noteq> 0\<close>
  shows \<open>\<exists>\<gamma>. b = \<gamma> *\<^sub>C d\<close>
proof (cases \<open>d = 0\<close>)
  case False
  from \<open>a \<noteq> 0\<close> obtain \<psi> where \<psi>: \<open>a *\<^sub>V \<psi> \<noteq> 0\<close>
    by (metis cblinfun.zero_left cblinfun_eqI)
  have \<open>(a \<otimes>\<^sub>o b) (\<psi> \<otimes>\<^sub>s \<phi>) = (c \<otimes>\<^sub>o d) (\<psi> \<otimes>\<^sub>s \<phi>)\<close> for \<phi>
    using assms by simp
  then have eq2: \<open>(a \<psi>) \<otimes>\<^sub>s (b \<phi>) = (c \<psi>) \<otimes>\<^sub>s (d \<phi>)\<close> for \<phi>
    by (simp add: tensor_op_ell2)
  then have eq2': \<open>(d \<phi>) \<otimes>\<^sub>s (c \<psi>) = (b \<phi>) \<otimes>\<^sub>s (a \<psi>)\<close> for \<phi>
    by (metis swap_ell2_tensor)
  from False obtain \<phi>0 where \<phi>0: \<open>d \<phi>0 \<noteq> 0\<close>
    by (metis cblinfun.zero_left cblinfun_eqI)
  obtain \<gamma> where \<open>c \<psi> = \<gamma> *\<^sub>C a \<psi>\<close>
    apply atomize_elim
    using eq2' \<phi>0 by (rule tensor_ell2_almost_injective)
  with eq2 have \<open>(a \<psi>) \<otimes>\<^sub>s (b \<phi>) = (a \<psi>) \<otimes>\<^sub>s (\<gamma> *\<^sub>C d \<phi>)\<close> for \<phi>
    by (simp add: tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  then have \<open>b \<phi> = \<gamma> *\<^sub>C d \<phi>\<close> for \<phi>
    by (smt (verit, best) \<psi> complex_vector.scale_cancel_right tensor_ell2_almost_injective tensor_ell2_nonzero tensor_ell2_scaleC2)
  then have \<open>b = \<gamma> *\<^sub>C d\<close>
    by (simp add: cblinfun_eqI)
  then show ?thesis
    by auto
next
  case True
  then have \<open>c \<otimes>\<^sub>o d = 0\<close>
    by (metis add_cancel_right_left tensor_op_right_add)
  then have \<open>a \<otimes>\<^sub>o b = 0\<close>
    using assms(1) by presburger
  with \<open>a \<noteq> 0\<close> have \<open>b = 0\<close>
    by (meson tensor_op_nonzero)
  then show ?thesis
    by auto
qed

lemma tensor_ell2_0_left[simp]: \<open>tensor_ell2 0 x = 0\<close>
  apply transfer by auto

lemma tensor_ell2_0_right[simp]: \<open>tensor_ell2 x 0 = 0\<close>
  apply transfer by auto

lemma tensor_op_0_left[simp]: \<open>tensor_op 0 x = (0 :: ('a::finite*'b::finite) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('c::finite*'d::finite) ell2)\<close>
  apply (rule equal_ket)
  by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)

lemma tensor_op_0_right[simp]: \<open>tensor_op x 0 = (0 :: ('a::finite*'b::finite) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('c::finite*'d::finite) ell2)\<close>
  apply (rule equal_ket)
  by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)

lemma bij_tensor_ell2_one_dim_left:
  assumes \<open>\<psi> \<noteq> 0\<close>
  shows \<open>bij (\<lambda>x::'b::finite ell2. (\<psi> :: 'a::CARD_1 ell2) \<otimes>\<^sub>s x)\<close>
proof (rule bijI)
  show \<open>inj (\<lambda>x::'b::finite ell2. (\<psi> :: 'a::CARD_1 ell2) \<otimes>\<^sub>s x)\<close>
    using assms by (rule inj_tensor_ell2_right)
  have \<open>\<exists>x. \<psi> \<otimes>\<^sub>s x = \<phi>\<close> for \<phi> :: \<open>('a*'b) ell2\<close>
  proof (use assms in transfer)
    fix \<psi> :: \<open>'a \<Rightarrow> complex\<close> and \<phi> :: \<open>'a*'b \<Rightarrow> complex\<close>
    assume \<open>has_ell2_norm \<phi>\<close> and \<open>\<psi> \<noteq> (\<lambda>_. 0)\<close>
    define c where \<open>c = \<psi> undefined\<close>
    then have \<open>\<psi> a = c\<close> for a
      apply (subst everything_the_same[of _ undefined])
      by simp
    with \<open>\<psi> \<noteq> (\<lambda>_. 0)\<close> have \<open>c \<noteq> 0\<close>
      by auto

    define x where \<open>x j = \<phi> (undefined, j) / c\<close> for j
    have \<open>(\<lambda>(i, j). \<psi> i * x j) = \<phi>\<close>
      apply (auto intro!: ext simp: x_def \<open>\<psi> _ = c\<close> \<open>c \<noteq> 0\<close>)
      apply (subst (2) everything_the_same[of _ undefined])
      by simp
    then show \<open>\<exists>x\<in>Collect has_ell2_norm. (\<lambda>(i, j). \<psi> i * x j) = \<phi>\<close>
      apply (rule bexI[where x=x])
      by simp
  qed

  then show \<open>surj (\<lambda>x::'b::finite ell2. (\<psi> :: 'a::CARD_1 ell2) \<otimes>\<^sub>s x)\<close>
    by (metis surj_def)
qed

lemma bij_tensor_op_one_dim_left:
  assumes \<open>a \<noteq> 0\<close>
  shows \<open>bij (\<lambda>x::'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2. (a :: 'a::{CARD_1,enum} ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::{CARD_1,enum} ell2) \<otimes>\<^sub>o x)\<close>
proof (rule bijI)
  define t where \<open>t = (\<lambda>x::'c ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd ell2. (a :: 'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2) \<otimes>\<^sub>o x)\<close>
  define i where
    \<open>i = tensor_lift (\<lambda>(x::'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2) (y::'c ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd ell2). (one_dim_iso x / one_dim_iso a) *\<^sub>C y)\<close>

  have [simp]: \<open>clinear i\<close>
    by (auto intro!: tensor_lift_clinear simp: i_def cbilinear_def clinearI scaleC_add_left add_divide_distrib)
  have [simp]: \<open>clinear t\<close>
    by (simp add: t_def)
  have \<open>i (x \<otimes>\<^sub>o y) = (one_dim_iso x / one_dim_iso a) *\<^sub>C y\<close> for x y
    by (auto intro!: clinearI tensor_lift_correct[THEN fun_cong, THEN fun_cong] simp: t_def i_def cbilinear_def  scaleC_add_left add_divide_distrib)
  then have \<open>t (i (x \<otimes>\<^sub>o y)) = x \<otimes>\<^sub>o y\<close> for x y
    apply (simp add: t_def)
    by (smt (z3) assms complex_vector.scale_eq_0_iff nonzero_mult_div_cancel_right one_dim_scaleC_1 scaleC_scaleC tensor_op_scaleC_left tensor_op_scaleC_right times_divide_eq_left)
  then have \<open>t (i x) = x\<close> for x
    apply (rule_tac fun_cong[where x=x])
    apply (rule tensor_extensionality)
    by (auto intro: clinear_compose complex_vector.module_hom_ident simp flip: o_def[of t i])
  then show \<open>surj t\<close>
    by (rule surjI)

  show \<open>inj t\<close>
    unfolding t_def using assms by (rule inj_tensor_right)
qed

lemma swap_ell2_selfinv[simp]: \<open>swap_ell2 o\<^sub>C\<^sub>L swap_ell2 = id_cblinfun\<close>
  apply (rule tensor_ell2_extensionality)
  by auto

lemma bij_tensor_op_one_dim_right:
  assumes \<open>b \<noteq> 0\<close>
  shows \<open>bij (\<lambda>x::'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2. x \<otimes>\<^sub>o (b :: 'a::{CARD_1,enum} ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::{CARD_1,enum} ell2))\<close>
    (is \<open>bij ?f\<close>)
proof -
  let ?sf = \<open>(\<lambda>x. swap_ell2 o\<^sub>C\<^sub>L (?f x) o\<^sub>C\<^sub>L swap_ell2)\<close>
  let ?s = \<open>(\<lambda>x. swap_ell2 o\<^sub>C\<^sub>L x o\<^sub>C\<^sub>L swap_ell2)\<close>
  let ?g = \<open>(\<lambda>x::'c::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::finite ell2. (b :: 'a::{CARD_1,enum} ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::{CARD_1,enum} ell2) \<otimes>\<^sub>o x)\<close>
  have \<open>?sf = ?g\<close>
    by (auto intro!: ext tensor_ell2_extensionality simp add: swap_ell2_tensor tensor_op_ell2)
  have \<open>bij ?g\<close>
    using assms by (rule bij_tensor_op_one_dim_left)
  have \<open>?s o ?sf = ?f\<close>
    apply (auto intro!: ext simp: cblinfun_assoc_left)
    by (auto simp: cblinfun_assoc_right)
  also have \<open>bij ?s\<close>
    apply (rule o_bij[where g=\<open>(\<lambda>x. swap_ell2 o\<^sub>C\<^sub>L x o\<^sub>C\<^sub>L swap_ell2)\<close>])
     apply (auto intro!: ext simp: cblinfun_assoc_left)
    by (auto simp: cblinfun_assoc_right)
  show \<open>bij ?f\<close>
    apply (subst \<open>?s o ?sf = ?f\<close>[symmetric], subst \<open>?sf = ?g\<close>)
    using \<open>bij ?g\<close> \<open>bij ?s\<close> by (rule bij_comp)
qed

lemma overlapping_tensor:
  fixes a23 :: \<open>('a2::finite*'a3::finite) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('b2::finite*'b3::finite) ell2\<close>
    and b12 :: \<open>('a1::finite*'a2) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('b1::finite*'b2) ell2\<close>
  assumes eq: \<open>butterfly \<psi> \<psi>' \<otimes>\<^sub>o a23 = assoc_ell2 o\<^sub>C\<^sub>L (b12 \<otimes>\<^sub>o butterfly \<phi> \<phi>') o\<^sub>C\<^sub>L assoc_ell2'\<close>
  assumes \<open>\<psi> \<noteq> 0\<close> \<open>\<psi>' \<noteq> 0\<close> \<open>\<phi> \<noteq> 0\<close> \<open>\<phi>' \<noteq> 0\<close>
  shows \<open>\<exists>c. butterfly \<psi> \<psi>' \<otimes>\<^sub>o a23 = butterfly \<psi> \<psi>' \<otimes>\<^sub>o c \<otimes>\<^sub>o butterfly \<phi> \<phi>'\<close>
proof -
  note [[show_types]]
  let ?id1 = \<open>id_cblinfun :: unit ell2 \<Rightarrow>\<^sub>C\<^sub>L unit ell2\<close>
  note id_cblinfun_eq_1[simp del]
  define d where \<open>d = butterfly \<psi> \<psi>' \<otimes>\<^sub>o a23\<close>

  define \<psi>\<^sub>n \<psi>\<^sub>n' a23\<^sub>n where \<open>\<psi>\<^sub>n = \<psi> /\<^sub>C norm \<psi>\<close> and \<open>\<psi>\<^sub>n' = \<psi>' /\<^sub>C norm \<psi>'\<close> and \<open>a23\<^sub>n = norm \<psi> *\<^sub>C norm \<psi>' *\<^sub>C a23\<close>
  have [simp]: \<open>norm \<psi>\<^sub>n = 1\<close> \<open>norm \<psi>\<^sub>n' = 1\<close>
    using \<open>\<psi> \<noteq> 0\<close> \<open>\<psi>' \<noteq> 0\<close> by (auto simp: \<psi>\<^sub>n_def \<psi>\<^sub>n'_def norm_inverse)
  have n1: \<open>butterfly \<psi>\<^sub>n \<psi>\<^sub>n' \<otimes>\<^sub>o a23\<^sub>n = butterfly \<psi> \<psi>' \<otimes>\<^sub>o a23\<close>
    apply (auto simp: \<psi>\<^sub>n_def \<psi>\<^sub>n'_def a23\<^sub>n_def tensor_op_scaleC_left tensor_op_scaleC_right)
    by (metis (no_types, lifting) assms(2) assms(3) inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_eq_0_iff right_inverse scaleC_one)

  define \<phi>\<^sub>n \<phi>\<^sub>n' b12\<^sub>n where \<open>\<phi>\<^sub>n = \<phi> /\<^sub>C norm \<phi>\<close> and \<open>\<phi>\<^sub>n' = \<phi>' /\<^sub>C norm \<phi>'\<close> and \<open>b12\<^sub>n = norm \<phi> *\<^sub>C norm \<phi>' *\<^sub>C b12\<close>
  have [simp]: \<open>norm \<phi>\<^sub>n = 1\<close> \<open>norm \<phi>\<^sub>n' = 1\<close>
    using \<open>\<phi> \<noteq> 0\<close> \<open>\<phi>' \<noteq> 0\<close> by (auto simp: \<phi>\<^sub>n_def \<phi>\<^sub>n'_def norm_inverse)
  have n2: \<open>b12\<^sub>n \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n' = b12 \<otimes>\<^sub>o butterfly \<phi> \<phi>'\<close>
    apply (auto simp: \<phi>\<^sub>n_def \<phi>\<^sub>n'_def b12\<^sub>n_def tensor_op_scaleC_left tensor_op_scaleC_right)
    by (metis (no_types, lifting) assms(4) assms(5) field_class.field_inverse inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_hom.hom_0 scaleC_one)

  define c' :: \<open>(unit*'a2*unit) ell2 \<Rightarrow>\<^sub>C\<^sub>L (unit*'b2*unit) ell2\<close>
    where \<open>c' = (vector_to_cblinfun \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o vector_to_cblinfun \<phi>\<^sub>n)* o\<^sub>C\<^sub>L d
            o\<^sub>C\<^sub>L (vector_to_cblinfun \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o vector_to_cblinfun \<phi>\<^sub>n')\<close>

  define c'' :: \<open>'a2 ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b2 ell2\<close>
    where \<open>c'' = inv (\<lambda>c''. id_cblinfun \<otimes>\<^sub>o c'' \<otimes>\<^sub>o id_cblinfun) c'\<close>

  have *: \<open>bij (\<lambda>c''::'a2 ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b2 ell2. ?id1 \<otimes>\<^sub>o c'' \<otimes>\<^sub>o ?id1)\<close>
    apply (subst asm_rl[of \<open>_ = (\<lambda>x. id_cblinfun \<otimes>\<^sub>o x) o (\<lambda>c''. c'' \<otimes>\<^sub>o id_cblinfun)\<close>])
    using [[show_consts]]
    by (auto intro!: bij_comp bij_tensor_op_one_dim_left bij_tensor_op_one_dim_right)

  have c'_c'': \<open>c' = ?id1 \<otimes>\<^sub>o c'' \<otimes>\<^sub>o ?id1\<close>
    unfolding c''_def
    apply (rule surj_f_inv_f[where y=c', symmetric])
    using * by (rule bij_is_surj)

  define c :: \<open>'a2 ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b2 ell2\<close>
    where \<open>c = c'' /\<^sub>C norm \<psi> /\<^sub>C norm \<psi>' /\<^sub>C norm \<phi> /\<^sub>C norm \<phi>'\<close>

  have aux: \<open>assoc_ell2' o\<^sub>C\<^sub>L (assoc_ell2 o\<^sub>C\<^sub>L x o\<^sub>C\<^sub>L assoc_ell2') o\<^sub>C\<^sub>L assoc_ell2 = x\<close> for x
    apply (simp add: cblinfun_assoc_left)
    by (simp add: cblinfun_assoc_right)
  have aux2: \<open>(assoc_ell2 o\<^sub>C\<^sub>L ((x \<otimes>\<^sub>o y) \<otimes>\<^sub>o z) o\<^sub>C\<^sub>L assoc_ell2') = x \<otimes>\<^sub>o (y \<otimes>\<^sub>o z)\<close> for x y z
    apply (rule equal_ket, rename_tac xyz)
    apply (case_tac xyz, hypsubst_thin)
    by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor tensor_op_ell2)

  have \<open>d = (butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L d o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun)\<close>
    by (auto simp: d_def n1[symmetric] comp_tensor_op cnorm_eq_1[THEN iffD1])
  also have \<open>\<dots> = (butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L assoc_ell2 o\<^sub>C\<^sub>L (b12\<^sub>n \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n')
                  o\<^sub>C\<^sub>L assoc_ell2' o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun)\<close>
    by (auto simp: d_def eq n2 cblinfun_assoc_left)
  also have \<open>\<dots> = (butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L assoc_ell2 o\<^sub>C\<^sub>L
               ((id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n) o\<^sub>C\<^sub>L (b12\<^sub>n \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n') o\<^sub>C\<^sub>L (id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n' \<phi>\<^sub>n'))
               o\<^sub>C\<^sub>L assoc_ell2' o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun)\<close>
    by (auto simp: comp_tensor_op cnorm_eq_1[THEN iffD1])
  also have \<open>\<dots> = (butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L assoc_ell2 o\<^sub>C\<^sub>L
               ((id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n) o\<^sub>C\<^sub>L (assoc_ell2' o\<^sub>C\<^sub>L d o\<^sub>C\<^sub>L assoc_ell2) o\<^sub>C\<^sub>L (id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n' \<phi>\<^sub>n'))
               o\<^sub>C\<^sub>L assoc_ell2' o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun)\<close>
    by (auto simp: d_def n2 eq aux)
  also have \<open>\<dots> = ((butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L (assoc_ell2 o\<^sub>C\<^sub>L (id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n) o\<^sub>C\<^sub>L assoc_ell2'))
               o\<^sub>C\<^sub>L d o\<^sub>C\<^sub>L ((assoc_ell2 o\<^sub>C\<^sub>L (id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n' \<phi>\<^sub>n') o\<^sub>C\<^sub>L assoc_ell2') o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun))\<close>
    by (auto simp: sandwich_def cblinfun_assoc_left)
  also have \<open>\<dots> = (butterfly \<psi>\<^sub>n \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n)
               o\<^sub>C\<^sub>L d o\<^sub>C\<^sub>L (butterfly \<psi>\<^sub>n' \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o butterfly \<phi>\<^sub>n' \<phi>\<^sub>n')\<close>
    apply (simp only: tensor_id[symmetric] comp_tensor_op aux2)
    by (simp add: cnorm_eq_1[THEN iffD1])
  also have \<open>\<dots> = (vector_to_cblinfun \<psi>\<^sub>n \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o vector_to_cblinfun \<phi>\<^sub>n)
               o\<^sub>C\<^sub>L c' o\<^sub>C\<^sub>L (vector_to_cblinfun \<psi>\<^sub>n' \<otimes>\<^sub>o id_cblinfun \<otimes>\<^sub>o vector_to_cblinfun \<phi>\<^sub>n')*\<close>
    apply (simp add: c'_def butterfly_def_one_dim[where 'c="unit ell2"] cblinfun_assoc_left comp_tensor_op
                      tensor_op_adjoint cnorm_eq_1[THEN iffD1])
    by (simp add: cblinfun_assoc_right comp_tensor_op)
  also have \<open>\<dots> = butterfly \<psi>\<^sub>n \<psi>\<^sub>n' \<otimes>\<^sub>o c'' \<otimes>\<^sub>o butterfly \<phi>\<^sub>n \<phi>\<^sub>n'\<close>
    by (simp add: c'_c'' comp_tensor_op tensor_op_adjoint butterfly_def_one_dim[symmetric])
  also have \<open>\<dots> = butterfly \<psi> \<psi>' \<otimes>\<^sub>o c \<otimes>\<^sub>o butterfly \<phi> \<phi>'\<close>
    by (simp add: \<psi>\<^sub>n_def \<psi>\<^sub>n'_def \<phi>\<^sub>n_def \<phi>\<^sub>n'_def c_def tensor_op_scaleC_left tensor_op_scaleC_right)
  finally have d_c: \<open>d = butterfly \<psi> \<psi>' \<otimes>\<^sub>o c \<otimes>\<^sub>o butterfly \<phi> \<phi>'\<close>
    by -
  then show ?thesis
    by (auto simp: d_def)
qed

lemma norm_tensor_ell2: \<open>norm (a \<otimes>\<^sub>s b) = norm a * norm b\<close>
  apply transfer
  by (simp add: ell2_norm_finite sum_product sum.cartesian_product case_prod_beta
      norm_mult power_mult_distrib flip: real_sqrt_mult)

lemma bounded_cbilinear_tensor_ell2[bounded_cbilinear]: \<open>bounded_cbilinear (\<otimes>\<^sub>s)\<close>
proof standard
  fix a a' :: "'a ell2" and b b' :: "'b ell2" and r :: complex
  show \<open>tensor_ell2 (a + a') b = tensor_ell2 a b + tensor_ell2 a' b\<close>
    by (meson tensor_ell2_add1)
  show \<open>tensor_ell2 a (b + b') = tensor_ell2 a b + tensor_ell2 a b'\<close>
    by (simp add: tensor_ell2_add2)
  show \<open>tensor_ell2 (r *\<^sub>C a) b = r *\<^sub>C tensor_ell2 a b\<close>
    by (simp add: tensor_ell2_scaleC1)
  show \<open>tensor_ell2 a (r *\<^sub>C b) = r *\<^sub>C tensor_ell2 a b\<close>
    by (simp add: tensor_ell2_scaleC2)
  show \<open>\<exists>K. \<forall>a b. norm (tensor_ell2 a b) \<le> norm a * norm b * K \<close>
    apply (rule exI[of _ 1])
    by (simp add: norm_tensor_ell2)
qed

end


theory Chapter2_MyList
  imports Main
begin

(* Contains original definition of nat and list *)

datatype bool = True | False

fun conj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "conj True True = True"
| "conj _ _ = False"

datatype nat = O | Suc nat

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add nat.O n = n"
| "add (Suc m) n = Suc (add m n)"

lemma add_02 [simp]: "add m nat.O = m"
  apply (induction m)
  apply (auto)
  done

(* List *)
datatype 'a list = Nil | Cons 'a "'a list"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "app Nil ys = ys"
| "app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
  "rev Nil = Nil"
| "rev (Cons x xs) = app (rev xs) (Cons x Nil)"

lemma app_Nil2 [simp]: "app xs Nil = xs"
  apply (induction xs)
  apply (auto)
  done

lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
  apply (induction xs)
  apply (auto)
  done

lemma rev_app [simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
  apply (induction xs)
  apply (auto)
  done

theorem rev_rev [simp]: "rev (rev xs) = xs"
  apply (induction xs)
  apply (auto)
  done

(* Exercise 2.2 *)
theorem add_assoc [simp]: "add n (add m l) = add (add n m) l"
  apply (induction n)
  apply (auto)
  done

lemma add_comm' [simp]: "add n (Suc m) = Suc (add n m)"
  apply (induction n)
   apply (auto)
  done

theorem add_comm [simp]: "add n m = add m n"
  apply (induction m)
   apply (auto)
  done

fun double :: "nat \<Rightarrow> nat" where
  "double nat.O = nat.O"
| "double (Suc n) = Suc (Suc (double n))"

theorem double_add_twice[simp]: "double n = add n n"
  apply (induction n)
   apply (auto)
  done

(* Exercise 2.9 *)
fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd nat.O m = m"
| "itadd (Suc n) m = itadd n (Suc m)"

theorem itadd_add : "itadd n m = add n m"
  apply (induction n arbitrary:m)
   apply (auto)
  done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_10
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

theorem property0 :
  "((rev (rev y)) = y)"
  apply(induct y)(*"(induct rule: rev.induct)" is equally good.*)
   apply fastforce
  apply(subst rev.simps)
  (*common sub-term generalization*)
  apply(subgoal_tac "\<And>rev_y. rev (rev_y) = y \<longrightarrow> rev (x (rev_y) (cons2 x1 nil2)) = cons2 x1 y")
   apply fastforce
  apply(thin_tac "rev (rev y) = y")
  apply(rule meta_allI)
  back
  back
  back
  apply(induct_tac rev_y)
   apply auto
  done

theorem property0' :
  "((rev (rev y)) = y)"
  apply(induct rule:rev.induct) (*"(induct y)" is equally good*)
  apply fastforce
  apply(subst rev.simps)
  (*common sub-term generalization*)
  apply(subgoal_tac "\<And>rev_y. rev (rev_y) = xs \<longrightarrow> rev (x (rev_y) (cons2 z nil2)) = cons2 z xs")
   apply fastforce
  apply(thin_tac "rev (rev xs) = xs")
  apply(rule meta_allI)
  back
  back
  back
  apply(induct_tac rev_y)
   apply auto
  done
end


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

section \<open>First-Order Logic: propositional examples (classical version)\<close>

theory Propositional_Cla
imports FOL
begin

text \<open>commutative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>

lemma \<open>P \<and> Q \<longrightarrow> Q \<and> P\<close>
  by (tactic "IntPr.fast_tac \<^context> 1")

lemma \<open>P \<or> Q \<longrightarrow> Q \<or> P\<close>
  by fast

text \<open>associative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma \<open>(P \<and> Q) \<and> R \<longrightarrow> P \<and> (Q \<and> R)\<close>
  by fast

lemma \<open>(P \<or> Q) \<or> R \<longrightarrow>  P \<or> (Q \<or> R)\<close>
  by fast

text \<open>distributive laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma \<open>(P \<and> Q) \<or> R \<longrightarrow> (P \<or> R) \<and> (Q \<or> R)\<close>
  by fast

lemma \<open>(P \<or> R) \<and> (Q \<or> R) \<longrightarrow> (P \<and> Q) \<or> R\<close>
  by fast

lemma \<open>(P \<or> Q) \<and> R \<longrightarrow> (P \<and> R) \<or> (Q \<and> R)\<close>
  by fast

lemma \<open>(P \<and> R) \<or> (Q \<and> R) \<longrightarrow> (P \<or> Q) \<and> R\<close>
  by fast

text \<open>Laws involving implication\<close>

lemma \<open>(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R) \<longleftrightarrow> (P \<or> Q \<longrightarrow> R)\<close>
  by fast

lemma \<open>(P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))\<close>
  by fast

lemma \<open>((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> ((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<longrightarrow> R) \<longrightarrow> R\<close>
  by fast

lemma \<open>\<not> (P \<longrightarrow> R) \<longrightarrow> \<not> (Q \<longrightarrow> R) \<longrightarrow> \<not> (P \<and> Q \<longrightarrow> R)\<close>
  by fast

lemma \<open>(P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)\<close>
  by fast

text \<open>Propositions-as-types\<close>

\<comment> \<open>The combinator K\<close>
lemma \<open>P \<longrightarrow> (Q \<longrightarrow> P)\<close>
  by fast

\<comment> \<open>The combinator S\<close>
lemma \<open>(P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)\<close>
  by fast

\<comment> \<open>Converse is classical\<close>
lemma \<open>(P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q \<or> R)\<close>
  by fast

lemma \<open>(P \<longrightarrow> Q) \<longrightarrow> (\<not> Q \<longrightarrow> \<not> P)\<close>
  by fast

text \<open>Schwichtenberg's examples (via T. Nipkow)\<close>

lemma stab_imp: \<open>(((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q\<close>
  by fast

lemma stab_to_peirce:
  \<open>(((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> (((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q)
    \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P\<close>
  by fast

lemma peirce_imp1:
  \<open>(((Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> Q)
    \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q) \<longrightarrow> P \<longrightarrow> Q\<close>
  by fast

lemma peirce_imp2: \<open>(((P \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> ((P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P\<close>
  by fast

lemma mints: \<open>((((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> Q) \<longrightarrow> Q\<close>
  by fast

lemma mints_solovev: \<open>(P \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R\<close>
  by fast

lemma tatsuta:
  \<open>(((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P5\<close>
  by fast

lemma tatsuta1:
  \<open>(((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9)
  \<longrightarrow> (((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7 \<longrightarrow> P5\<close>
  by fast

end


theory Type
  imports "../00Utils/Variable"
begin

datatype ty =
  TyVar var
  | Base
  | Arrow ty ty

primrec tvars :: "ty \<Rightarrow> var set" where
  "tvars (TyVar y) = {y}"
| "tvars Base = {}"
| "tvars (Arrow t\<^sub>1 t\<^sub>2) = tvars t\<^sub>1 \<union> tvars t\<^sub>2"

fun tsubst :: "var \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty" where
  "tsubst x t' (TyVar y) = (if x = y then t' else TyVar y)"
| "tsubst x t' Base = Base"
| "tsubst x t' (Arrow t\<^sub>1 t\<^sub>2) = Arrow (tsubst x t' t\<^sub>1) (tsubst x t' t\<^sub>2)"

lemma [simp]: "tsubst x (TyVar x) t = t"
  by (induction t) simp_all

lemma [simp]: "y \<notin> tvars t \<Longrightarrow> tsubst y t' (tsubst x (TyVar y) t) = tsubst x t' t"
  by (induction t) simp_all

lemma tsubst_arrow [consumes 1, case_names TyVar Arrow]: "Arrow t\<^sub>1 t\<^sub>2 = tsubst y t' tt \<Longrightarrow>
  (t' = Arrow t\<^sub>1 t\<^sub>2 \<Longrightarrow> tt = TyVar y \<Longrightarrow> P) \<Longrightarrow>
    (\<And>tt\<^sub>1 tt\<^sub>2. t\<^sub>1 = tsubst y t' tt\<^sub>1 \<Longrightarrow> t\<^sub>2 = tsubst y t' tt\<^sub>2 \<Longrightarrow> tt = Arrow tt\<^sub>1 tt\<^sub>2 \<Longrightarrow> P) \<Longrightarrow> P"
  by (induction tt) (simp_all split: if_splits)

end


section \<open>Start\<close>

theory Isabelle_Intro
  imports Main
begin

section \<open>Predefined Inductive Type\<close>

fun sum_up_to :: "nat \<Rightarrow> nat" where
  "sum_up_to 0 = 0" |
  "sum_up_to (Suc n) = sum_up_to n + Suc n"

lemma gauss: "sum_up_to n = n * (n + 1) div 2"
proof (induction n)
  case 0
  show ?case by simp
next
  case Suc
  then show ?case by simp
qed

section \<open>Custom Inductive Type\<close>

datatype 'a tree =
  Leaf |
  Branch 'a "('a tree)" "('a tree)"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
  mirror_leaf: "mirror Leaf = Leaf" |
  mirror_branch: "mirror (Branch x t\<^sub>1 t\<^sub>2) = Branch x (mirror t\<^sub>2) (mirror t\<^sub>1)"

lemma double_mirror: "mirror (mirror t) = t"
proof (induction t)
  case Leaf
  show ?case by simp
next
  case (Branch x t\<^sub>1 t\<^sub>2)
  have "mirror (mirror (Branch x t\<^sub>1 t\<^sub>2)) = mirror (Branch x (mirror t\<^sub>2) (mirror t\<^sub>1))"
    by (rule arg_cong [OF mirror_branch])
  also have "\<dots> = Branch x (mirror (mirror t\<^sub>1)) (mirror (mirror t\<^sub>2))"
    by (rule mirror_branch)
  also have "\<dots> = Branch x t\<^sub>1 t\<^sub>2"
    by (simp add: Branch.IH)
  finally show ?case .
qed

section \<open>Computation Induction\<close>

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse _ [] = []" |
  "intersperse _ [x] = [x]" |
  "intersperse y (x # xs) = x # y # intersperse y xs"

value "intersperse (0 :: nat) [1]"
value "intersperse (0 :: nat) [1, 2]"
value "intersperse (0 :: nat) [1, 2, 3]"

lemma "intersperse (0 :: nat) [1, 2, 3] = [1, 0, 2, 0, 3]" by simp

lemma intersperse_map: "map f (intersperse y xs) = intersperse (f y) (map f xs)"
proof (induction xs rule: intersperse.induct)
  case 1
  show ?case by simp
next
  case 2
  show ?case by simp
next
  case 3
  then show ?case by simp
qed

lemma "map f (intersperse y xs) = intersperse (f y) (map f xs)" \<comment> \<open>now proved more explicitly\<close>
proof (induction xs rule: intersperse.induct)
  fix y
  show "map f (intersperse y []) = intersperse (f y) (map f [])"
    by simp
next
  fix y and x
  show "map f (intersperse y [x]) = intersperse (f y) (map f [x])"
    by simp
next
  fix y and x\<^sub>1 and x\<^sub>2 and xs
  assume "map f (intersperse y (x\<^sub>2 # xs)) = intersperse (f y) (map f (x\<^sub>2 # xs))"
  then show "map f (intersperse y (x\<^sub>1 # x\<^sub>2 # xs)) = intersperse (f y) (map f (x\<^sub>1 # x\<^sub>2 # xs))"
    by simp
qed

section \<open>Inductive Predicate\<close>

inductive closure :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" for r where
  refl: "closure r x x" |
  step: "\<lbrakk> r x y; closure r y z \<rbrakk> \<Longrightarrow> closure r x z"

inductive closure' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" for r where
  refl': "closure' r x x" |
  step': "\<lbrakk> closure' r x y; r y z \<rbrakk> \<Longrightarrow> closure' r x z"

lemma closure_implies_closure': "closure r x y \<Longrightarrow> closure' r x y"
proof (induction rule: closure.induct)
  case refl
  show ?case by (fact refl')
next
  case (step x y z)
  from `closure' r y z` and `r x y` show "closure' r x z"
  proof (induction rule: closure'.induct)
    case refl'
    then show ?case by (blast intro: closure'.intros)
  next
    case step'
    then show ?case by (blast intro: closure'.step')
  qed
qed

section \<open>End\<close>

end