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>tensor_ell2 a b \<bullet>\<^sub>C tensor_ell2 c d = (a \<bullet>\<^sub>C c) * (b \<bullet>\<^sub>C d)\<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. x \<bullet>\<^sub>C (assoc_ell2 *\<^sub>V a))\<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. a \<bullet>\<^sub>C y)\<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. (assoc_ell2' *\<^sub>V a) \<bullet>\<^sub>C y)\<close> for y :: \<open>(('a \<times> 'b) \<times> 'c) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have \<open>(assoc_ell2' *\<^sub>V ket x) \<bullet>\<^sub>C ket y = ket x \<bullet>\<^sub>C (assoc_ell2 *\<^sub>V ket y)\<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>(assoc_ell2' *\<^sub>V ket x) \<bullet>\<^sub>C y = ket x \<bullet>\<^sub>C (assoc_ell2 *\<^sub>V y)\<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>(assoc_ell2' *\<^sub>V x) \<bullet>\<^sub>C y = x \<bullet>\<^sub>C (assoc_ell2 *\<^sub>V y)\<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. x \<bullet>\<^sub>C (swap_ell2 *\<^sub>V a))\<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. a \<bullet>\<^sub>C y)\<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. (swap_ell2 *\<^sub>V a) \<bullet>\<^sub>C y)\<close> for y :: \<open>('b \<times> 'a) ell2\<close>
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have \<open>(swap_ell2 *\<^sub>V ket x) \<bullet>\<^sub>C ket y = ket x \<bullet>\<^sub>C (swap_ell2 *\<^sub>V ket y)\<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>(swap_ell2 *\<^sub>V ket x) \<bullet>\<^sub>C y = ket x \<bullet>\<^sub>C (swap_ell2 *\<^sub>V y)\<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>(swap_ell2 *\<^sub>V x) \<bullet>\<^sub>C y = x \<bullet>\<^sub>C (swap_ell2 *\<^sub>V y)\<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 Listas
imports Main
begin

section "El tipo de las listas"

text {* ('a list) es el tipo de las listas con elementos de tipo 'a *}
datatype 'a lista = Nil | Cons "'a" "'a lista"

text {* Ejemplos de inferencia de tipo. *}
term "Nil"
  (* da "lista.Nil" :: "'a lista" *)
term "Cons 1 Nil"
  (* da "lista.Cons 1 lista.Nil" :: "'a lista" *)

text {* Declaración para acortar los nombres. *}
declare [[names_short]]

text {* Ejemplos de inferencia de tipo con nombres acortados. *}
term "Nil"
  (* da "Nil" :: "'a lista" *)
term "Cons 1 Nil"
  (* da "Cons 1 lista.Nil" :: "'a lista" *)

section "Funciones sobre listas: conc e inversa"

text {* (conc xs ys) es la concatenación de las listas xs e ys. Por
  ejemplo,
     conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))
     = Cons a (Cons b (Cons c (Cons d Nil)))
*}
fun conc :: "'a lista \<Rightarrow> 'a lista \<Rightarrow> 'a lista"
where
  "conc Nil ys         = ys"
| "conc (Cons x xs) ys = Cons x (conc xs ys)"

value "conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))"
lemma "conc (Cons a (Cons b Nil)) (Cons c (Cons d Nil))
       = Cons a (Cons b (Cons c (Cons d Nil)))" by simp

text {* (inversa xs) es la inversa de la lista xs. Por ejemplo,
*}
fun inversa :: "'a lista \<Rightarrow> 'a lista"
where
  "inversa Nil         = Nil"
| "inversa (Cons x xs) = conc (inversa xs) (Cons x Nil)"

value "inversa (Cons a (Cons b (Cons c Nil)))"
lemma "inversa (Cons a (Cons b (Cons c Nil)))
       = Cons c (Cons b (Cons a Nil))" by simp

export_code inversa in Haskell
(* El resultado es
  module Listas (Lista, inversa) where {

  import Prelude ((==), ...
  import qualified Prelude;

  data Lista a = Nil | Cons a (Lista a);

  conc :: forall a. Lista a -> Lista a -> Lista a;
  conc Nil ys = ys;
  conc (Cons x xs) ys = Cons x (conc xs ys);

  inversa :: forall a. Lista a -> Lista a;
  inversa Nil = Nil;
  inversa (Cons x xs) = conc (inversa xs) (Cons x Nil);
}
*)

section "Ejemplo de búsqueda descendente de la demostración"

text {* El objetivo de esta sección es mostrar cómo se conjeturan lemas
  auxiliares para la demostración de la idempotencia de la función
  inversa.

  Se mostrarán cómo los errores de las pruebas ayudan a conjeturar los
  lemas.
*}

text {* Primer intento de prueba de inversa_inversa. *}
theorem inversa_inversa_1:
  "inversa (inversa xs) = xs"
apply (induction xs)
apply auto
oops

text {* Queda sin demostrar el siguiente objetivo:
     inversa (inversa xs) = xs \<Longrightarrow>
     inversa (conc (inversa xs) (Cons x1 Nil)) = Cons x1 xs

  Se observa que contiene la expresión
     inversa (conc (inversa xs) (Cons x1 Nil))
  que se puede simplificar a
     conc (Cons x1 Nil) (inversa (inversa xs))
  con el siguiente lema:
     inversa (conc xs ys) = conc (inversa ys) (inversa xs)
*}

text {* Primer intento de prueba de inversa_conc. *}
lemma inversa_conc_1:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply auto
oops

text {* Queda sin demostrar el objetivo
     inversa ys = conc (inversa ys) Nil
  Se puede demostrar con el siguiente lema
     conc xs Nil = xs
*}

text {* Prueba de conc_Nil2. *}
lemma conc_Nil2:
  "conc xs Nil = xs"
apply (induction xs)
apply auto
done

text {* Segundo intento de prueba de inversa_conc usando conc_Nil2. *}
lemma inversa_conc_2:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply (auto simp add: conc_Nil2)
oops

text {* Queda sin probar el objetivo
     inversa (conc xs ys) = conc (inversa ys) (inversa xs) \<Longrightarrow>
       conc (conc (inversa ys) (inversa xs)) (Cons x1 Nil) =
       conc (inversa ys) (conc (inversa xs) (Cons x1 Nil))
  que se puede simplificar usando la propiedad asociativa de conc.
*}

text {* Prueba de asociatividad de conc. *}
lemma conc_asoc:
  "conc (conc xs ys) zs = conc xs (conc ys zs)"
apply (induction xs)
apply auto
done

text {* Prueba de inversa_conc usando conc_Nil2 y conc_asoc. *}
lemma inversa_conc:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
apply (induction xs)
apply (auto simp add: conc_Nil2 conc_asoc)
done

text {* Prueba de inversa_inversa usando inversa_conc. *}
theorem inversa_inversa:
  "inversa (inversa xs) = xs"
apply (induction xs)
apply (auto simp add: inversa_conc)
done

text {* Una vez encontrada la demostración, se puede modificar la
  presentación declarando los lemas como reglas de simplificación, como
  se muestra a continuación. *}

lemma conc_Nil2' [simp]:
  "conc xs Nil = xs"
by (induction xs) auto

lemma conc_asoc' [simp]:
  "conc (conc xs ys) zs = conc xs (conc ys zs)"
by (induction xs) auto

lemma inversa_conc' [simp]:
  "inversa (conc xs ys) = conc (inversa ys) (inversa xs)"
by (induction xs) auto

theorem inversa_inversa':
  "inversa (inversa xs) = xs"
by (induction xs) auto

section "Ejemplo de cálculo con listas"

value "a # [b,c]"
  (* da "[a, b, c]" *)
value "hd [a,b,c]"
  (* da "a" *)
value "tl [a,b,c]"
  (* da "[b, c]" *)
value "set [b,a,c]"
  (* da "{b, a, c}" :: "'a set" *)
value "set [b,a,c] = set [c,a,b,a,c]"
  (* da "True" *)
value "map f [a,b,c]"
  (* da "[f a, f b, f c]" *)
value "last [a,b,c]"
  (* da "c" *)
value "butlast [a,b,c]"
  (* da  "[a, b]" *)
value "[a,b] @ [c,a,d]"
  (* da "[a, b, c, a, d]" *)
value "rev [a,b,c,d]"
  (* da "[d, c, b, a]" *)
value "filter (op > (Suc (Suc 0))) [0,Suc 0, Suc (Suc (Suc 0)), 0]"
  (* da "[0, Suc 0, 0]" *)
value "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]"
  (* da "True" *)
value "fold f [a,b,c] x"
  (* da "f c (f b (f a x))" *)
value "fold (op +) [Suc 0, Suc (Suc 0), Suc 0] 0"
  (* da "Suc (Suc (Suc (Suc 0)))" *)
value "foldr f [a,b,c] x"
  (* da "f a (f b (f c x))" *)
value "foldr (op -) [Suc (Suc (Suc 0)), Suc 0, Suc 0] 0"
  (* da ""Suc (Suc (Suc 0))" *)
value "foldl f x [a,b,c]"
  (* da "f (f (f x a) b) c" *)
value "foldl (op -) 0 [Suc (Suc (Suc 0)), Suc 0, Suc 0]"
  (* da "0" *)
value "concat [[a,b],[c],[d,a,c]]"
  (* da "[a, b, c, d, a, c]" *)
value "drop 2 [a,b,c,d]"
  (* da "[c, d]" *)
value "drop 6 [a,b,c,d]"
  (* da "[]" *)
value "take 2 [a,b,c,d]"
  (* da "[a, b]" *)
value "take 6 [a,b,c,d]"
  (* da "[a, b, c, d]" *)
value "nth [a,b,c,d] (Suc (Suc 0))"
  (* da "c" *)
value "list_update [a,b,c,d] (Suc (Suc 0)) g"
  (* da "[a, b, g, d]" *)
value "[a,b,c,d][Suc (Suc 0) := g]"
  (* da "[a, b, g, d]" *)
value "takeWhile (op > (Suc (Suc 0))) [0,Suc 0, Suc (Suc (Suc 0)), 0]"
  (* da "[0, Suc 0]" *)
value "dropWhile (op > (Suc (Suc 0))) [0,Suc 0, Suc (Suc (Suc 0)), 0]"
  (* da "[Suc (Suc (Suc 0)), 0]" *)
value "zip [a,b,c] [d,e,f,g]"
  (* da "[(a, d), (b, e), (c, f)]" *)
value "List.product [a,b] [c,d]"
  (* da "[(a, c), (a, d), (b, c), (b, d)]" *)
value "product_lists [[a,b], [c], [d,e]]"
  (* da "[[a, c, d], [a, c, e], [b, c, d], [b, c, e]]" *)
value "List.insert (Suc 0) [0,Suc (Suc 0)]"
  (* da "[Suc 0, 0, Suc (Suc 0)]" *)
value "List.insert (Suc (Suc 0)) [0,Suc (Suc 0)]"
  (* da "[0, Suc (Suc 0)]" *)
value "List.union [0,Suc 0] [0,Suc (Suc 0)]"
  (* da "[Suc 0, 0, Suc (Suc 0)]" *)
value "find (op = (Suc 0)) [0,Suc 0, Suc (Suc (Suc 0)), 0]"
  (* da "Some (Suc 0)" *)
value "find (op = (Suc (Suc 0))) [0,Suc 0, Suc (Suc (Suc 0)), 0]"
  (* da "None" *)
value "count_list [0,Suc 0,0, Suc (Suc 0), 0] 0"
  (* da "Suc (Suc (Suc 0))" *)
value "remove1 0 [Suc 0, 0, Suc (Suc 0), 0]"
  (* da "[Suc 0, Suc (Suc 0), 0]" *)
value "removeAll 0 [Suc 0, 0, Suc (Suc 0), 0]"
  (* da "[Suc 0, Suc (Suc 0)]" *)
value "distinct [1::nat,2,3]"
  (* da "True" *)
value "distinct [1::nat,2,1]"
  (* da "False" *)
value "remdups [1::nat,2,1]"
  (* da "[Suc (Suc 0), Suc 0]" *)
value "replicate 3 a"
  (* da "[a, a, a]" *)
value "length [a,b,c]"
  (* da "Suc (Suc (Suc 0))" :: nat*)
value "int (length [a,b,c])"
  (* da "3" :: int *)
value "int (size [a,b,c])"
  (* da "3" :: int *)
value "enumerate 0 [b,a,c]"
  (* da "[(0, b), (Suc 0, a), (Suc (Suc 0), c)]" *)
value "enumerate 1 [b,a,c]"
  (* da "[(Suc 0, b), (Suc (Suc 0), a), (Suc (Suc (Suc 0)), c)]" *)
value "[1..<4]"
  (* da  "[Suc 0, Suc (Suc 0), Suc (Suc (Suc 0))]" *)
value "rotate1 [a,b,c]"
  (* da "[b, c, a]" *)
value "rotate1 [b,c,a]"
  (* da "[c, a, b]" *)
value "(rotate1 ^^ 2) [a,b,c]"
  (* da "[c, a, b]" *)
value "rotate 2 [a,b,c]"
  (* da "[c, a, b]" *)
value "sublists [a,b,c]"
  (* da "[[a, b, c], [a, b], [a, c], [a], [b, c], [b], [c], []]" *)
value "splice [a,b,c] [x,y,z]"
  (* da "[a, x, b, y, c, z]" *)
value "splice [a,b,c,d] [x,y]"
  (* da "[a, x, b, y, c, d]" *)
value "List.n_lists 2 [a,b,c]"
  (* da [[a,a], [b,a], [c,a], [a,b], [b,b], [c,b], [a,c], [b,c], [c,c]]" *)
value "sort [Suc 0, 0, Suc (Suc 0)]"
  (* da "[0, Suc 0, Suc (Suc 0)]" *)

end


(* 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.*)
  theory TIP_sort_nat_HSortIsSort
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun toHeap :: "Nat list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 q (nil2)) = cons2 q (nil2)"
| "hpairwise (cons2 q (cons2 r qs)) =
     cons2 (hmerge q r) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 q (nil2)) = q"
| "hmerging (cons2 q (cons2 z x2)) =
     hmerging (hpairwise (cons2 q (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "Nat list => Nat list" where
  "hsort x = toList (toHeap2 x)"

theorem property0 :
  "((hsort xs) = (isort xs))"
  oops

end


text \<open>Stuff about triangle numbers, in particular triangular root \<close>

theory Triangle_Extensions
  imports "Poly_Reductions_Lib.Landau_Auxiliaries"
begin

lemma triangle_Sum: "triangle n = (\<Sum>x\<in>{1..n}. x)"
  by (induction n) (auto simp add: triangle_def)

(* Proofs in here are ugly, look at again, I also do quite a lot by just doing it on reals and transfering back *)

(* Stuff for moving to the reals *)
lemma sqrt_power2_iff_eq: "x \<ge> 0 \<Longrightarrow> y\<ge>0\<Longrightarrow> sqrt x = y \<longleftrightarrow> x = y^2" by auto

lemma triangle_invert_real: "n\<ge>0 \<Longrightarrow> (sqrt (8*(n*(n+1) / 2)+1) - 1) / 2 = n"
proof-
  have s: "(8*(n*(n+1) / 2)+1) = (2 * n + 1)^2" if "n\<ge>0"
    using that by (auto simp add: power2_eq_square distrib_left mult.commute)
  have "sqrt (8*(n*(n+1) / 2)+1) = 2*n + 1" if "n\<ge>0"
    using that by (simp add: s sqrt_power2_iff_eq) algebra
  then show ?thesis if "n\<ge>0"
    using that by auto
qed

lemma sqrt_Discrete_sqrt: "nat (floor (sqrt n)) = Discrete.sqrt n"
  apply (rule antisym)
  apply (rule le_sqrtI)
  apply (smt (verit, ccfv_threshold) of_int_floor_le of_nat_0_le_iff of_nat_le_of_nat_power_cancel_iff
      of_nat_nat real_less_lsqrt real_sqrt_ge_0_iff zero_le_floor)
  apply (rule sqrt_leI)
  by (simp add: le_nat_floor real_le_rsqrt)

lemma divide2_div2: "nat (floor (n/2)) = n div 2"
  by linarith
lemma divide2_div2': "nat (floor (n/2)) = nat (floor (n::real)) div 2"
  by linarith

lemma triangular_part_real: "nat (floor (((sqrt (8*n + 1)) -1) /2)) = (Discrete.sqrt (8*n + 1) -1) div 2"
  apply (simp add: divide2_div2' nat_diff_distrib')
  by (metis add.commute of_nat_Suc of_nat_mult of_nat_numeral sqrt_Discrete_sqrt)

lemma triangle_invert_real_typ: "(sqrt (8*(n*(n+1) / 2)+1) - 1) / 2 = (n::nat)"
  using triangle_invert_real by simp

lemma triangle_invert_real_typ': "nat (floor ((sqrt (8*(n*(n+1) / 2)+1) - 1) / 2)) = (n::nat)"
  using triangle_invert_real by simp

text \<open>Triangular root\<close>

definition "tsqrt n \<equiv> (Discrete.sqrt (8*n + 1) - 1) div 2"

lemma tsqrt_0[simp]: "tsqrt 0 = 0"
  by code_simp
lemma tsqrt_1[simp]: "tsqrt 1 = 1"
  by code_simp
lemma tsqrt_2[simp]: "tsqrt 2 = 1"
  by code_simp

lemma tsqrt_correct[simp]: "tsqrt (triangle n) = n"
proof(unfold triangle_def tsqrt_def)
  have s: "real (n * Suc n div 2) = real n * (real n + 1) / 2"
    by (smt (verit, del_insts) Multiseries_Expansion.intyness_1 add.commute double_gauss_sum gauss_sum
        id_apply nat_1_add_1 nonzero_mult_div_cancel_left of_nat_Suc of_nat_eq_id of_nat_mult plus_1_eq_Suc)
  show "(Discrete.sqrt (8 * (n * Suc n div 2) + 1) - 1) div 2 = n"
    apply (subst triangular_part_real[symmetric]) apply (subst s)
    using triangle_invert_real_typ' by simp
qed

lemma mono_tsqrt: "mono tsqrt"
  unfolding tsqrt_def
  apply (rule monoI)
  unfolding tsqrt_def
  by simp (meson Suc_le_mono diff_le_mono div_le_mono le_less mono_sqrt' mult_le_mono)

lemma mono_tsqrt': "x\<le>y \<Longrightarrow> tsqrt x \<le> tsqrt y"
  using mono_tsqrt by (drule monoD)

text \<open>Alternative triangular root definition, based on how \<^const>\<open>Discrete.sqrt\<close> is defined
  Copied lemmas/proofs as well and modified them for some free properties.

  General way of this construction might be a student project?
\<close>

definition "tsqrt_alt n \<equiv> Max {m. triangle m \<le> n}"

lemma tsqrt_alt_aux:
  fixes n :: nat
  shows "finite {m. triangle m \<le> n}" and "{m. triangle m \<le> n} \<noteq> {}"
proof -
  { fix m
    assume "triangle m \<le> n"
    then have "m \<le> n"
      by (cases m) (simp_all)
  } note ** = this
  then have "{m. triangle m \<le> n} \<subseteq> {m. m \<le> n}" by auto
  then show "finite {m. triangle m \<le> n}" by (rule finite_subset) rule
  have "triangle 0 \<le> n" by simp
  then show *: "{m. triangle m \<le> n} \<noteq> {}" by blast
qed

lemma tsqrt_alt_unique:
  assumes "triangle m \<le> n" "n < triangle (Suc m)"
  shows   "tsqrt_alt n = m"
proof -
  have "m' \<le> m" if "triangle m' \<le> n" for m'
  proof -
    note that
    also note assms(2)
    finally have "m' < Suc m" (* Apparently I already have some connection to tsqrt here *)
      by (metis le_neq_implies_less less_or_eq_imp_le mono_tsqrt' nat_neq_iff tsqrt_correct)
    thus "m' \<le> m" by simp
  qed
  with \<open>triangle m \<le> n\<close> tsqrt_alt_aux[of n] show ?thesis unfolding tsqrt_alt_def
    by (intro antisym Max.boundedI Max.coboundedI) simp_all
qed

lemma triangle_nat_le_imp_le:
  fixes m n :: nat
  assumes "triangle m \<le> n"
  shows "m \<le> n"
proof (cases m)
  case 0
  then show ?thesis
    by simp
next
  case (Suc nat)
  then show ?thesis
    using assms by auto
qed

(* Real proof *)
lemma triangle_nat_le_eq_le: "triangle m \<le> triangle n \<longleftrightarrow> m \<le> n"
  for m n :: nat
  by (metis linorder_le_cases mono_tsqrt' tsqrt_correct verit_la_disequality)

(* basically linear search, delete this code equation once you have a better one *)
lemma tsqrt_alt_code_1 [code]: "tsqrt_alt n = Max (Set.filter (\<lambda>m. triangle m \<le> n) {0..n})"
proof -
  from triangle_nat_le_imp_le [of _ n] have "{m. m \<le> n \<and> triangle m \<le> n} = {m. triangle m \<le> n}" by auto
  then show ?thesis by (simp add: tsqrt_alt_def Set.filter_def)
qed

lemma tsqrt_alt_inverse_triangle [simp]: "tsqrt_alt (triangle n) = n"
proof -
  have "{m. m \<le> n} \<noteq> {}" by auto
  then have "Max {m. m \<le> n} \<le> n" by auto
  then show ?thesis
    by (auto simp add: tsqrt_alt_def triangle_nat_le_eq_le intro: antisym)
qed

lemma tsqrt_alt_zero [simp]: "tsqrt_alt 0 = 0"
  using tsqrt_alt_inverse_triangle [of 0] by simp

lemma tsqrt_alt_one [simp]: "tsqrt_alt 1 = 1"
  using tsqrt_alt_inverse_triangle [of 1] by simp

lemma mono_tsqrt_alt: "mono tsqrt_alt"
proof
  fix m n :: nat
  have *: "0 * 0 \<le> m" by simp
  assume "m \<le> n"
  then show "tsqrt_alt m \<le> tsqrt_alt n"
    apply (auto intro!: Max_mono \<open>0 * 0 \<le> m\<close> finite_less_ub simp add: tsqrt_alt_def triangle_nat_le_imp_le)
    apply (metis triangle_0 zero_le)
    done
qed

lemma mono_tsqrt_alt_': "m \<le> n \<Longrightarrow> tsqrt_alt m \<le> tsqrt_alt n"
  using mono_tsqrt_alt unfolding mono_def by auto

lemma tsqrt_alt_greater_zero_iff [simp]: "tsqrt_alt n > 0 \<longleftrightarrow> n > 0"
proof -
  have *: "0 < Max {m. triangle m \<le> n} \<longleftrightarrow> (\<exists>a\<in>{m. triangle m \<le> n}. 0 < a)"
    by (rule Max_gr_iff) (fact tsqrt_alt_aux)+
  show ?thesis
  proof
    assume "0 < tsqrt_alt n"
    then have "0 < Max {m. triangle m \<le> n}" by (simp add: tsqrt_alt_def)
    with * show "0 < n" by (auto dest: triangle_nat_le_imp_le)
  next
    assume "0 < n"
    then have "triangle 1 \<le> n \<and> 0 < (1::nat)" by simp
    then have "\<exists>q. triangle q \<le> n \<and> 0 < q" ..
    with * have "0 < Max {m. triangle m \<le> n}" by blast
    then show "0 < tsqrt_alt n" by (simp add: tsqrt_alt_def)
  qed
qed

(* No idea what this proof does, find out sometime :) *)
lemma tsqrt_alt_triangle_le [simp]: "triangle (tsqrt_alt n) \<le> n" (* FIXME tune proof *)
proof (cases "n > 0")
  case False then show ?thesis by simp
next
  case True then have "tsqrt_alt n > 0" by simp
  then have "mono (times (Max {m. triangle m \<le> n}))" by (auto intro: mono_times_nat simp add: tsqrt_alt_def)
  then have *: "Max {m. triangle m \<le> n} * Max {m. triangle m \<le> n} = Max (times (Max {m. triangle m \<le> n}) ` {m. triangle m \<le> n})"
    using tsqrt_alt_aux [of n] by (rule mono_Max_commute)
  have "\<And>a. a * a \<le> n \<Longrightarrow> Max {m. m * m \<le> n} * a \<le> n"
  proof -
    fix q
    assume "q * q \<le> n"
    show "Max {m. m * m \<le> n} * q \<le> n"
    proof (cases "q > 0")
      case False then show ?thesis by simp
    next
      case True then have "mono (times q)" by (rule mono_times_nat)
      then have "q * Max {m. m * m \<le> n} = Max (times q ` {m. m * m \<le> n})"
        using sqrt_aux [of n] by (auto simp add: power2_eq_square intro: mono_Max_commute)
      then have "Max {m. m * m \<le> n} * q = Max (times q ` {m. m * m \<le> n})" by (simp add: ac_simps)
      moreover have "finite ((*) q ` {m. m * m \<le> n})"
        by (metis (mono_tags) finite_imageI finite_less_ub le_square)
      moreover have "\<exists>x. x * x \<le> n"
        by (metis \<open>q * q \<le> n\<close>)
      ultimately show ?thesis
        by simp (metis \<open>q * q \<le> n\<close> le_cases mult_le_mono1 mult_le_mono2 order_trans)
    qed
  qed
  then have "Max ((*) (Max {m. m * m \<le> n}) ` {m. m * m \<le> n}) \<le> n"
    apply (subst Max_le_iff)
      apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
     apply auto
    apply (metis le0 mult_0_right)
    done
  with * show ?thesis
    using tsqrt_alt_aux Max_in by (auto simp add: tsqrt_alt_def)
qed

lemma tsqrt_alt_le: "tsqrt_alt n \<le> n"
  using tsqrt_alt_aux [of n] by (auto simp add: tsqrt_alt_def intro: triangle_nat_le_imp_le)

lemma Suc_tsqrt_alt_triangle_gt: "n < triangle (Suc (tsqrt_alt n))"
  using Max_ge[OF tsqrt_alt_aux(1), of "tsqrt_alt n + 1" n]
  by (cases "n < triangle (Suc (tsqrt_alt n))") (simp_all add: tsqrt_alt_def)

lemma le_tsqrt_alt_iff: "x \<le> tsqrt_alt y \<longleftrightarrow> triangle x \<le> y"
proof -
  have "x \<le> tsqrt_alt y \<longleftrightarrow> (\<exists>z. triangle z \<le> y \<and> x \<le> z)"
    using Max_ge_iff[OF tsqrt_alt_aux, of x y] by (simp add: tsqrt_alt_def)
  also have "\<dots> \<longleftrightarrow> triangle x \<le> y"
  proof safe
    fix z assume "x \<le> z" "triangle z \<le> y"
    thus "triangle x \<le> y" by (intro le_trans[of "triangle x" "triangle z" y]) (simp_all add: triangle_nat_le_eq_le)
  qed auto
  finally show ?thesis .
qed

lemma le_tsqrt_altI: "triangle x \<le> y \<Longrightarrow> x \<le> tsqrt_alt y"
  by (simp add: le_tsqrt_alt_iff)

lemma tsqrt_alt_le_iff: "tsqrt_alt y \<le> x \<longleftrightarrow> (\<forall>z. triangle z \<le> y \<longrightarrow> z \<le> x)"
  using Max.bounded_iff[OF tsqrt_alt_aux] by (simp add: tsqrt_alt_def)

lemma sqrt_leI:
  "(\<And>z. triangle z \<le> y \<Longrightarrow> z \<le> x) \<Longrightarrow> tsqrt_alt y \<le> x"
  by simp

lemma triangle_less_imp_less: "triangle x < triangle y \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
  by (simp add: less_le_not_le triangle_nat_le_eq_le)
lemma tsqrt_alt_Suc:
  "tsqrt_alt (Suc n) = (if \<exists>m. Suc n = triangle m then Suc (tsqrt_alt n) else tsqrt_alt n)"
proof cases
  assume "\<exists> m. Suc n = triangle m"
  then obtain m where m_def: "Suc n = triangle m" by blast
  then have lhs: "tsqrt_alt (Suc n) = m" by simp
  from m_def tsqrt_alt_triangle_le[of n]
    have "triangle (tsqrt_alt n) < triangle m" by linarith
  with triangle_less_imp_less have lt_m: "tsqrt_alt n < m" by blast
  from m_def Suc_tsqrt_alt_triangle_gt[of "n"]
    have "triangle m \<le> triangle (Suc(tsqrt_alt n))"
      by linarith
  with triangle_nat_le_eq_le have "m \<le> Suc (tsqrt_alt n)" by blast
  with lt_m have "m = Suc (tsqrt_alt n)" by simp
  with lhs m_def show ?thesis by metis
next
  assume asm: "\<not> (\<exists> m. Suc n = triangle m)"
  hence "Suc n \<noteq> triangle (tsqrt_alt (Suc n))" by simp
  with tsqrt_alt_triangle_le[of "Suc n"]
    have "tsqrt_alt (Suc n) \<le> tsqrt_alt n" by (intro le_tsqrt_altI) linarith
  moreover have "tsqrt_alt (Suc n) \<ge> tsqrt_alt n"
    by (intro monoD[OF mono_tsqrt_alt]) simp_all
  ultimately show ?thesis using asm by simp
qed

(* Continue with direct definition, once again by moving to reals*)

lemma triangle_tsqrt_le_real:
  "nat (floor (((sqrt (8 * n + 1) - 1) / 2) * ((1 + ((sqrt (8 * n + 1) - 1) / 2)) / 2))) \<le> n"
  by (auto simp add: triangle_def field_simps)

lemma tsqrt_real: "tsqrt n = nat (floor (((sqrt (8 * n + 1) - 1) / 2)))"
  apply (simp add: tsqrt_def field_simps)
  by (metis One_nat_def add.commute divide2_div2' mult.commute plus_1_eq_Suc triangular_part_real)

lemma triangle_tsqrt_real_pre:
  "triangle (tsqrt n) = nat (floor ((nat (floor (((sqrt (8 * n + 1) - 1) / 2))) * nat (floor (1 + ((sqrt (8 * n + 1) - 1) / 2)))) / 2))"
  unfolding triangle_def tsqrt_real divide2_div2
  apply (simp add: field_simps)
  by (smt (verit, best) Suc_eq_plus1 add_mult_distrib2 floor_diff_of_int int_nat_eq
      nat_int_comparison(1) nat_mult_1_right of_int_1 of_nat_1 of_nat_add plus_1_eq_Suc real_average_minus_first)

lemma triangle_tsqrt_le_real_bound: "nat (floor ((nat (floor (((sqrt (8 * n + 1) - 1) / 2))) * nat (floor (1 + ((sqrt (8 * n + 1) - 1) / 2)))) / 2))
  \<le> nat (floor (((sqrt (8 * n + 1) - 1) / 2) * ((1 + ((sqrt (8 * n + 1) - 1) / 2)) / 2)))"
  by (metis div_le_mono divide2_div2' le_mult_nat_floor times_divide_eq_right triangle_invert_real_typ triangle_invert_real_typ')

lemma triangle_tsqrt_le: "triangle (tsqrt n) \<le> n"
  unfolding triangle_tsqrt_real_pre
  using triangle_tsqrt_le_real triangle_tsqrt_le_real_bound
  by (meson le_trans)

lemma tsqrt_unique:
  assumes "triangle m \<le> n" "n < triangle (Suc m)"
  shows "tsqrt n = m"
  using assms triangle_tsqrt_le tsqrt_correct
  by (metis le_SucE le_antisym mono_tsqrt' nat_less_le)

lemma tsqrt_tsqrt: "tsqrt_alt n = tsqrt n"
  by (metis Suc_tsqrt_alt_triangle_gt tsqrt_unique tsqrt_alt_triangle_le)

lemma tsqrt_Suc:
  "tsqrt (Suc n) = (if \<exists>m. Suc n = triangle m then Suc (tsqrt n) else tsqrt n)"
  using tsqrt_alt_Suc tsqrt_tsqrt by force

end


(*  Title:      Sigma_Algebra.thy

    Author:     Stefan Richter, Markus Wenzel, TU Muenchen
    License:    LGPL

Changes for Accordance to Joe Hurd's conventions
and additions by Stefan Richter 2002
*)

subsection \<open>Sigma algebras \label{sec:sigma}\<close>

theory Sigma_Algebra imports Main begin

text \<open>The $\isacommand {theory}$ command commences a formal document and enumerates the
  theories it depends on. With the \<open>Main\<close> theory, a standard
  selection of useful HOL theories excluding the real
  numbers is loaded. This theory includes and builds upon a tiny theory of the
  same name by Markus Wenzel. This theory as well as \<open>Measure\<close>
  in \ref{sec:measure-spaces} is heavily
  influenced by Joe Hurd's thesis \<^cite>\<open>"hurd2002"\<close> and has been designed to keep the terminology as
  consistent as possible with that work.

  Sigma algebras are an elementary concept in measure
  theory. To measure --- that is to integrate --- functions, we first have
  to measure sets. Unfortunately, when dealing with a large universe,
  it is often not possible to consistently assign a measure to every
  subset. Therefore it is necessary to define the set of measurable
  subsets of the universe. A sigma algebra is such a set that has
  three very natural and desirable properties.\<close>

definition
  sigma_algebra:: "'a set set \<Rightarrow> bool" where
  "sigma_algebra A \<longleftrightarrow>
  {} \<in> A \<and> (\<forall>a. a \<in> A \<longrightarrow> -a \<in> A) \<and>
  (\<forall>a. (\<forall> i::nat. a i \<in> A) \<longrightarrow> (\<Union>i. a i) \<in> A)"

text \<open>
  The $\isacommand {definition}$ command defines new constants, which
  are just named functions in HOL. Mind that the third condition
  expresses the fact that the union of countably many sets in $A$ is
  again a set in $A$ without explicitly defining the notion of
  countability.

  Sigma algebras can naturally be created as the closure of any set of
  sets with regard to the properties just postulated. Markus Wenzel
  wrote the following
  inductive definition of the $\isa {sigma}$ operator.\<close>

inductive_set
  sigma :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set"
  where
    basic: "a \<in> A \<Longrightarrow> a \<in> sigma A"
  | empty: "{} \<in> sigma A"
  | complement: "a \<in> sigma A \<Longrightarrow> -a \<in> sigma A"
  | Union: "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Union>i. a i) \<in> sigma A"

text \<open>He also proved the following basic facts. The easy proofs are omitted.
\<close>

theorem sigma_UNIV: "UNIV \<in> sigma A"
(*<*)proof -
  have "{} \<in> sigma A" by (rule sigma.empty)
  hence "-{} \<in> sigma A" by (rule sigma.complement)
  also have "-{} = UNIV" by simp
  finally show ?thesis .
qed(*>*)

theorem sigma_Inter:
  "(\<And>i::nat. a i \<in> sigma A) \<Longrightarrow> (\<Inter>i. a i) \<in> sigma A"
(*<*) proof -
  assume "\<And>i::nat. a i \<in> sigma A"
  hence "\<And>i::nat. -(a i) \<in> sigma A" by (rule sigma.complement)
  hence "(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.Union)
  hence "-(\<Union>i. -(a i)) \<in> sigma A" by (rule sigma.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed(*>*)

text \<open>It is trivial to show the connection between our first
  definitions. We use the opportunity to introduce the proof syntax.\<close>

theorem assumes sa: "sigma_algebra A"
  \<comment> \<open>Named premises are introduced like this.\<close>

  shows sigma_sigma_algebra: "sigma A = A"
proof

  txt \<open>The $\isacommand {proof}$ command alone invokes a single standard rule to
    simplify the goal. Here the following two subgoals emerge.\<close>

  show "A \<subseteq> sigma A"
    \<comment> \<open>The $\isacommand {show}$ command starts the proof of a subgoal.\<close>

    by (auto simp add: sigma.basic)

  txt \<open>This is easy enough to be solved by an automatic step,
    indicated by the keyword $\isacommand {by}$. The method $\isacommand {auto}$ is stated in parentheses, with attributes to it following.  In
    this case, the first introduction rule for the $\isacommand {sigma}$
    operator is given as an extra simplification rule.\<close>

  show "sigma A \<subseteq> A"
  proof

    txt \<open>Because this goal is not quite as trivial, another proof is
      invoked, delimiting a block as in a programming language.\<close>

    fix x
    \<comment> \<open>A new named variable is introduced.\<close>

    assume "x \<in> sigma A"

    txt \<open>An assumption is made that must be justified by the current proof
      context. In this case the corresponding fact had been generated
      by a rule automatically invoked by the inner $\isacommand {proof}$
      command.\<close>

    from this sa show "x \<in> A"

      txt \<open>Named facts can explicitly be given to the proof methods using
        $\isacommand {from}$. A special name is \<open>this\<close>, which denotes
        current facts generated by the last command. Usually $\isacommand
        {from}$ \<open>this sa\<close> --- remember that \<open>sa\<close> is an assumption from above
        --- is abbreviated to $\isacommand {with}$ \<open>sa\<close>, but in this case the order of
        facts is relevant for the following method and $\isacommand
        {with}$
        would have put the current facts last.\<close>

      by (induct rule: sigma.induct) (auto simp add: sigma_algebra_def)

    txt \<open>Two methods may be carried out at $\isacommand {by}$. The first
      one applies induction here via the canonical rule generated by the
      inductive definition above, while the latter solves the
      resulting subgoals by an automatic step involving
      simplification.\<close>

  qed
qed

text "These two steps finish their respective proofs, checking
  that all subgoals have been proven."

text \<open>To end this theory we prove a special case of the \<open>sigma_Inter\<close> theorem above. It seems trivial that
  the fact holds for two sets as well as for countably many.
  We get a first taste of the cost of formal reasoning here, however. The
  idea must be made precise by exhibiting a concrete sequence of
  sets.\<close>

primrec trivial_series:: "'a set \<Rightarrow> 'a set \<Rightarrow> (nat \<Rightarrow> 'a set)"
where
  "trivial_series a b 0 = a"
| "trivial_series a b (Suc n) = b"

text \<open>Using $\isacommand {primrec}$, primitive recursive functions over
  inductively defined data types --- the natural numbers in this case ---
  may be constructed.\<close>

theorem assumes s: "sigma_algebra A" and a: "a \<in> A" and b: "b \<in> A"
  shows sigma_algebra_inter: "a \<inter> b \<in> A"
proof -
    \<comment> \<open>This form of $\isacommand {proof}$ foregoes the application of a rule.\<close>

  have "a \<inter> b = (\<Inter>i::nat. trivial_series a b i)"

    txt \<open>Intermediate facts that do not solve any subgoals yet are established this way.\<close>

  proof (rule set_eqI)

    txt \<open>The  $\isacommand {proof}$ command may also take one explicit method
      as an argument like the single rule application in this instance.\<close>

    fix x

    {
      fix i
      assume "x \<in> a \<inter> b"
      hence "x \<in> trivial_series a b i" by (cases i) auto
        \<comment> \<open>This is just an abbreviation for $\isacommand {"from this have"}$.\<close>
    }

    txt \<open>Curly braces can be used to explicitly delimit
      blocks. In conjunction with $\isacommand {fix}$, universal
      quantification over the fixed variable $i$ is achieved
      for the last statement in the block, which is exported to the
      enclosing block.\<close>

    hence "x \<in> a \<inter> b \<Longrightarrow> \<forall>i. x \<in> trivial_series a b i"
      by fast
    also

    txt \<open>The statement $\isacommand {also}$ introduces calculational
      reasoning. This basically amounts to collecting facts. With
      $\isacommand {also}$, the current fact is added to a special list of
      theorems called the calculation and
      an automatically selected transitivity rule
      is additionally applied from the second collected fact on.\<close>

    { assume "\<And>i. x \<in> trivial_series a b i"
      hence "x \<in> trivial_series a b 0" and "x \<in> trivial_series a b 1"
        by this+
      hence "x \<in> a \<inter> b"
        by simp
    }
    hence "\<forall>i. x \<in> trivial_series a b i \<Longrightarrow> x \<in> a \<inter> b"
      by blast

    ultimately have "x \<in> a \<inter> b = (\<forall>i::nat. x \<in> trivial_series a b i)" ..

    txt \<open>The accumulated calculational facts including the current one
      are exposed to the next statement by  $\isacommand {ultimately}$ and
      the calculation list is then erased. The two dots after the
      statement here indicate proof by a single automatically
      selected rule.\<close>

    also have "\<dots> =  (x \<in> (\<Inter>i::nat. trivial_series a b i))"
      by simp
    finally show "x \<in> a \<inter> b = (x \<in> (\<Inter>i::nat. trivial_series a b i))" .

    txt \<open>The $\isacommand {finally}$ directive behaves like $\isacommand {ultimately}$
      with the addition of a further transitivity rule application. A
      single dot stands for proof by assumption.\<close>

  qed

  moreover have "(\<Inter>i::nat. trivial_series a b i) \<in> A"
  proof -
    { fix i
      from a b have "trivial_series a b i \<in> A"
        by (cases i) auto
    }
    hence "\<And>i. trivial_series a b i \<in> sigma A"
      by (simp only: sigma.basic)
    hence "(\<Inter>i::nat. trivial_series a b i) \<in> sigma A"
      by (simp only: sigma_Inter)
    with s show ?thesis
      by (simp only: sigma_sigma_algebra)
  qed

  ultimately show ?thesis by simp
qed

text \<open>Of course, a like theorem holds for union instead of
  intersection.  But as we will not need it in what follows, the
  theory is finished with the following easy properties instead.
  Note that the former is a kind of generalization of the last result and
  could be used to  shorten its proof. Unfortunately, this one was needed ---
  and therefore found --- only late in the development.
\<close>

theorem sigma_INTER:
  assumes a:"(\<And>i::nat. i \<in> S \<Longrightarrow> a i \<in> sigma A)"
  shows "(\<Inter>i\<in>S. a i) \<in> sigma A"(*<*)
proof -
  from a have "\<And>i. (if i\<in>S then {} else UNIV) \<union> a i \<in> sigma A"
    by (simp add: sigma.intros sigma_UNIV)
  hence "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) \<in> sigma A"
    by (rule sigma_Inter)
  also have "(\<Inter>i. (if i\<in>S then {} else UNIV) \<union> a i) = (\<Inter>i\<in>S. a i)"
    by force
  finally show ?thesis .
qed(*>*)

lemma assumes s: "sigma_algebra a" shows sigma_algebra_UNIV: "UNIV \<in> a"(*<*)
proof -
  from s have "{}\<in>a" by (unfold sigma_algebra_def) blast
  with s show ?thesis by (unfold sigma_algebra_def) auto
qed(*>*)

end


section {*foundations\_on\_functions*}
theory
  foundations_on_functions

imports
  partial_functions

begin

definition left_total_on :: "
  ('A \<Rightarrow> 'B \<Rightarrow> bool)
  \<Rightarrow> 'A set
  \<Rightarrow> 'B set
  \<Rightarrow> bool"
  where
    "left_total_on R A B \<equiv>
  \<forall>a \<in> A. \<exists>b \<in> B. R a b"

definition right_total_on :: "
  ('A \<Rightarrow> 'B \<Rightarrow> bool)
  \<Rightarrow> 'A set
  \<Rightarrow> 'B set
  \<Rightarrow> bool"
  where
    "right_total_on R A B \<equiv>
  \<forall>b \<in> B. \<exists>a \<in> A. R a b"

definition bijection_on :: "
  ('a \<Rightarrow> 'b \<Rightarrow> bool)
  \<Rightarrow> 'a set
  \<Rightarrow> 'b set
  \<Rightarrow> bool"
  where
    "bijection_on F A B \<equiv>
  (\<forall>a \<in> A. \<exists>!b \<in> B. F a b)
  \<and> (\<forall>b \<in> B. \<exists>!a \<in> A. F a b)"

lemma bijection_on_RT: "
  bijection_on F A B
  \<Longrightarrow> a \<in> A
  \<Longrightarrow> \<exists>b\<in> B. F a b"
  apply(simp add: bijection_on_def)
  apply(force)
  done

lemma bijection_on_LT: "
  bijection_on F A B
  \<Longrightarrow> b \<in> B
  \<Longrightarrow> \<exists>a\<in> A. F a b"
  apply(simp add: bijection_on_def)
  apply(force)
  done

lemma bijection_on_RU: "
  bijection_on F A B
  \<Longrightarrow> a \<in> A
  \<Longrightarrow> b1 \<in> B
  \<Longrightarrow> b2 \<in> B
  \<Longrightarrow> F a b1
  \<Longrightarrow> F a b2
  \<Longrightarrow> b1 = b2"
  apply(simp add: bijection_on_def)
  apply(force)
  done

lemma bijection_on_LU: "
  bijection_on F A B
  \<Longrightarrow> b \<in> B
  \<Longrightarrow> a1 \<in> A
  \<Longrightarrow> a2 \<in> A
  \<Longrightarrow> F a1 b
  \<Longrightarrow> F a2 b
  \<Longrightarrow> a1=a2"
  apply(simp add: bijection_on_def)
  apply(force)
  done

lemma bijection_on_intro: "
  (\<forall>a\<in> A. \<exists>b\<in> B. F a b)
  \<Longrightarrow> (\<forall>b\<in> B. \<exists>a\<in> A. F a b)
  \<Longrightarrow> (\<forall>a\<in> A. \<forall>b1\<in> B. \<forall>b2\<in> B. F a b1 \<longrightarrow> F a b2 \<longrightarrow> b1 = b2)
  \<Longrightarrow> (\<forall>b\<in> B. \<forall>a1\<in> A. \<forall>a2\<in> A. F a1 b \<longrightarrow> F a2 b \<longrightarrow> a1 = a2)
  \<Longrightarrow> bijection_on F A B"
  apply(simp add: bijection_on_def)
  apply(rule conjI)
   apply(clarsimp)
   apply(erule_tac
      x="a"
      in ballE)
    prefer 2
    apply(force)
   apply(erule_tac
      x="a"
      in ballE)
    prefer 2
    apply(force)
   apply(clarsimp)
   apply(rule_tac
      a="b"
      in ex1I)
    apply(force)
   apply(force)
  apply(clarsimp)
  apply(erule_tac
      x="b"
      in ballE)
   prefer 2
   apply(force)
  apply(erule_tac
      x="b"
      in ballE)
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(rule_tac
      a="a"
      in ex1I)
   apply(force)
  apply(force)
  done

definition LT_ON :: "('\<Sigma> \<times> 'b)set \<Rightarrow> '\<Sigma> set \<Rightarrow> 'b set \<Rightarrow> bool" where
  "LT_ON R A B = (\<forall>x \<in> A. \<exists>y \<in> B. (x,y) \<in> R)"

end


(*
    Title:      Examples_Gauss_Jordan_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Examples of computations over matrices represented as nested IArrays\<close>

theory Examples_Gauss_Jordan_IArrays
imports
  System_Of_Equations_IArrays
  Determinants_IArrays
  Inverse_IArrays
  Code_Z2
  "HOL-Library.Code_Target_Numeral"
(*"HOL-Library.Code_Real_Approx_By_Float"*)
begin

subsection\<open>Transformations between nested lists nested IArrays\<close>
definition iarray_of_iarray_to_list_of_list :: "'a iarray iarray => 'a list list"
  where "iarray_of_iarray_to_list_of_list A = map IArray.list_of (map ((!!) A) [0..<IArray.length A])"

text\<open>The following definitions are also in the file \<open>Examples_on_Gauss_Jordan_Abstract\<close>.\<close>

text\<open>Definitions to transform a matrix to a list of list and vice versa\<close>
definition vec_to_list :: "'a^'n::{finite, enum} => 'a list"
  where "vec_to_list A = map (($) A) (enum_class.enum::'n list)"

definition matrix_to_list_of_list :: "'a^'n::{finite, enum}^'m::{finite, enum} => 'a list list"
  where "matrix_to_list_of_list A = map (vec_to_list) (map (($) A) (enum_class.enum::'m list))"

text\<open>This definition should be equivalent to \<open>vector_def\<close> (in suitable types)\<close>
definition list_to_vec :: "'a list => 'a^'n::{enum, mod_type}"
  where "list_to_vec xs = vec_lambda (% i. xs ! (to_nat i))"

lemma [code abstract]: "vec_nth (list_to_vec xs) = (%i. xs ! (to_nat i))"
  unfolding list_to_vec_def by fastforce

definition list_of_list_to_matrix :: "'a list list => 'a^'n::{enum, mod_type}^'m::{enum, mod_type}"
  where "list_of_list_to_matrix xs = vec_lambda (%i. list_to_vec (xs ! (to_nat i)))"

lemma [code abstract]: "vec_nth (list_of_list_to_matrix xs) = (%i. list_to_vec (xs ! (to_nat i)))"
  unfolding list_of_list_to_matrix_def by auto

subsection\<open>Examples\<close>

text\<open>The following three lemmas are presented in both this file and in the
\<open>Examples_Gauss_Jordan_Abstract\<close> one. They allow a more convenient printing of rational and
real numbers after evaluation. They have already been added to the repository version of Isabelle,
so after Isabelle2014 they should be removed from here.\<close>

lemma [code_post]:
  "int_of_integer (- 1) = - 1"
 by simp

lemma [code_abbrev]:
 "(of_rat (- 1) :: real) = - 1"
  by simp

lemma [code_post]:
 "(of_rat (- (1 / numeral k)) :: real) = - 1 / numeral k"
 "(of_rat (- (numeral k / numeral l)) :: real) = - numeral k / numeral l"
 by (simp_all add: of_rat_divide of_rat_minus)

text\<open>From here on, we do the computations in two ways. The first one consists of executing the abstract functions (which internally will execute the ones over iarrays).
The second one runs directly the functions over iarrays.\<close>

subsubsection\<open>Ranks, dimensions and Gauss Jordan algorithm\<close>
text\<open>In the following examples, the theorem \<open>matrix_to_iarray_rank\<close> (which is the file \<open>Gauss_Jordan_IArrays\<close>
  and it is a code unfold theorem) assures that the computation will be carried out using the iarrays representation.\<close>
value "vec.dim (col_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (null_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::rat^5^4))"

value "rank_iarray (IArray[IArray[1::rat,0,0,7,5],IArray[1,0,4,8,-1],IArray[1,0,0,9,8],IArray[1,2,3,6,5]])"
(*Identical matrices with coefficients in Z2 and R could have different rank in each field:*)
value "rank_iarray (IArray[IArray[1::real,0,1],IArray[1,1,0],IArray[0,1,1]])"
value "rank_iarray (IArray[IArray[1::bit,0,1],IArray[1,1,0],IArray[0,1,1]])"

text\<open>Examples on computing the Gauss Jordan algorithm.\<close>
value "iarray_of_iarray_to_list_of_list (matrix_to_iarray (Gauss_Jordan (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2)))"
value "iarray_of_iarray_to_list_of_list (Gauss_Jordan_iarrays(IArray[IArray[Complex 1 1,Complex 1 (- 1),Complex 0 0],IArray[Complex 2 (- 1),Complex 1 3,Complex 7 3]]))"

subsubsection\<open>Inverse of a matrix\<close>
text\<open>Examples on inverting matrices\<close>

definition "print_result_some_iarrays A = (if A = None then None else Some (iarray_of_iarray_to_list_of_list (the A)))"

value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8],[3,2,8,0,5,9,8],[3,2,8,4,0,9,8],[3,2,8,4,5,0,8],[3,2,8,4,5,9,0]]::real^7^7)
                    in print_result_some_iarrays (matrix_to_iarray_option (inverse_matrix A))"
value "let A=(IArray[IArray[1::real,1,2,4,5,9,8],IArray[3,0,8,4,5,0,8],IArray[3,2,0,4,5,9,8],IArray[3,2,8,0,5,9,8],IArray[3,2,8,4,0,9,8],IArray[3,2,8,4,5,0,8],IArray[3,2,8,4,5,9,0]])
                    in print_result_some_iarrays (inverse_matrix_iarray A)"

subsubsection\<open>Determinant of a matrix\<close>
text\<open>Examples on computing determinants of matrices\<close>

value "det (list_of_list_to_matrix ([[1,8,9,1,47],[7,2,2,5,9],[3,2,7,7,4],[9,8,7,5,1],[1,2,6,4,5]])::rat^5^5)"
value "det (list_of_list_to_matrix [[1,2,7,8,9],[3,4,12,10,7],[-5,4,8,7,4],[0,1,2,4,8],[9,8,7,13,11]]::rat^5^5)"

value "det_iarrays (IArray[IArray[1::real,2,7,8,9],IArray[3,4,12,10,7],IArray[-5,4,8,7,4],IArray[0,1,2,4,8],IArray[9,8,7,13,11]])"
value "det_iarrays (IArray[IArray[286,662,263,246,642,656,351,454,339,848],
IArray[307,489,667,908,103,47,120,133,85,834],
IArray[69,732,285,147,527,655,732,661,846,202],
IArray[463,855,78,338,786,954,593,550,913,378],
IArray[90,926,201,362,985,341,540,912,494,427],
IArray[384,511,12,627,131,620,987,996,445,216],
IArray[385,538,362,643,567,804,499,914,332,512],
IArray[879,159,312,187,827,503,823,893,139,546],
IArray[800,376,331,363,840,737,911,886,456,848],
IArray[900,737,280,370,121,195,958,862,957,754::real]])"

subsubsection\<open>Bases of the fundamental subspaces\<close>
text\<open>Examples on computing basis for null space, row space, column space and left null space.\<close>
(*Null_space basis:*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
  in vec_to_list` (basis_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_null_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_null_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_null_space_iarrays A)"

(*Row_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_row_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_row_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_row_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_row_space_iarrays A)"

(*Col_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_col_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_col_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_col_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_col_space_iarrays A)"

(*Left_null_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_left_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_left_null_space A)"

value "let A = (IArray[IArray[1::real,3,-2,0,2,0],IArray[2,6,-5,-2,4,-3],IArray[0,0,5,10,0,15],IArray[2,6,0,8,4,18]])
  in IArray.list_of` (basis_left_null_space_iarrays A)"
value "let A = (IArray[IArray[3::real,4,0,7],IArray[1,-5,2,-2],IArray[-1,4,0,3],IArray[1,-1,2,2]])
  in IArray.list_of` (basis_left_null_space_iarrays A)"

subsubsection\<open>Consistency and inconsistency\<close>

text\<open>Examples on checking the consistency/inconsistency of a system of equations. The theorems \<open>matrix_to_iarray_independent_and_consistent\<close> and
\<open>matrix_to_iarray_dependent_and_consistent\<close> which are code theorems and they are in the file \<open>System_Of_Equations_IArrays\<close>
assure the execution using the iarrays representation.\<close>

value "independent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "inconsistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[3,0,1],[0,7,0],[0,0,9]])::real^3^5) (list_to_vec([2,0,4,0,0])::real^5)"
value "dependent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0]])::real^3^2) (list_to_vec([3,4])::real^2)"
value "independent_and_consistent (mat 1::real^3^3) (list_to_vec([3,4,5])::real^3)"

subsubsection\<open>Solving systems of linear equations\<close>
text\<open>Examples on solving linear systems.\<close>
definition "print_result_system_iarrays A = (if A = None then None else Some (IArray.list_of (fst (the A)), IArray.list_of` (snd (the A))))"

value "let A = (list_of_list_to_matrix [[0,0,0],[0,0,0],[0,0,1]]::real^3^3); b=(list_to_vec [4,5,0]::real^3);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"
value "let A = (list_of_list_to_matrix [[3,2,5,2,7],[6,4,7,4,5],[3,2,-1,2,-11],[6,4,1,4,-13]]::real^5^4); b=(list_to_vec [0,0,0,0]::real^4);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"
value "let A = (list_of_list_to_matrix [[4,5,8],[9,8,7],[4,6,1]]::real^3^3); b=(list_to_vec [4,5,8]::real^3);
                  result = pair_vec_vecset (solve A b)
                  in print_result_system_iarrays (result)"

value "let A = (IArray[IArray[0::real,0,0],IArray[0,0,0],IArray[0,0,1]]); b=(IArray[4,5,0]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"
value "let A = (IArray[IArray[3::real,2,5,2,7],IArray[6,4,7,4,5],IArray[3,2,-1,2,-11],IArray[6,4,1,4,-13]]); b=(IArray[0,0,0,0]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"
value "let A = (IArray[IArray[4,5,8],IArray[9::real,8,7],IArray[4,6::real,1]]); b=(IArray[4,5,8]);
                  result = (solve_iarrays A b)
                  in print_result_system_iarrays (result)"

export_code
  rank_iarray
  inverse_matrix_iarray
  det_iarrays
  consistent_iarrays
  inconsistent_iarrays
  independent_and_consistent_iarrays
  dependent_and_consistent_iarrays
  basis_left_null_space_iarrays
  basis_null_space_iarrays
  basis_col_space_iarrays
  basis_row_space_iarrays
  solve_iarrays
  in SML
end