(*
Authors:

  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk
  Yijun He, University of Cambridge, yh403@cam.ac.uk
  with contributions by Hanna Lachnitt
*)

theory Quantum
imports
  Jordan_Normal_Form.Matrix
  "HOL-Library.Nonpos_Ints"
  Basics
  Binary_Nat
begin

section \<open>Qubits and Quantum Gates\<close>

subsection \<open>Qubits\<close>

text\<open>In this theory @{text cpx} stands for @{text complex}.\<close>

definition cpx_vec_length :: "complex vec \<Rightarrow> real" ("\<parallel>_\<parallel>") where
"cpx_vec_length v \<equiv> sqrt(\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2)"

lemma cpx_length_of_vec_of_list [simp]:
  "\<parallel>vec_of_list l\<parallel> = sqrt(\<Sum>i<length l. (cmod (l ! i))\<^sup>2)"
  apply (auto simp: cpx_vec_length_def vec_of_list_def vec_of_list_index)
  by (metis (no_types, lifting) dim_vec_of_list sum.cong vec_of_list.abs_eq vec_of_list_index)

lemma norm_vec_index_unit_vec_is_0 [simp]:
  assumes "j < n" and "j \<noteq> i"
  shows "cmod ((unit_vec n i) $ j) = 0"
  using assms by (simp add: unit_vec_def)

lemma norm_vec_index_unit_vec_is_1 [simp]:
  assumes "j < n" and "j = i"
  shows "cmod ((unit_vec n i) $ j) = 1"
proof -
  have f:"(unit_vec n i) $ j = 1"
    using assms by simp
  thus ?thesis
    by (simp add: f cmod_def)
qed

lemma unit_cpx_vec_length [simp]:
  assumes "i < n"
  shows "\<parallel>unit_vec n i\<parallel> = 1"
proof -
  have "(\<Sum>j<n. (cmod((unit_vec n i) $ j))\<^sup>2) = (\<Sum>j<n. if j = i then 1 else 0)"
    using norm_vec_index_unit_vec_is_0 norm_vec_index_unit_vec_is_1
    by (smt lessThan_iff one_power2 sum.cong zero_power2)
  also have "\<dots> = 1"
    using assms by simp
  finally have "sqrt (\<Sum>j<n. (cmod((unit_vec n i) $ j))\<^sup>2) = 1"
    by simp
  thus ?thesis
    using cpx_vec_length_def by simp
qed

lemma smult_vec_length [simp]:
  assumes "x \<ge> 0"
  shows "\<parallel>complex_of_real(x) \<cdot>\<^sub>v v\<parallel> = x * \<parallel>v\<parallel>"
proof-
  have "(\<lambda>i::nat.(cmod (complex_of_real x * v $ i))\<^sup>2) = (\<lambda>i::nat. (cmod (v $ i))\<^sup>2 * x\<^sup>2)"
    by (auto simp: norm_mult power_mult_distrib)
  then have "(\<Sum>i<dim_vec v. (cmod (complex_of_real x * v $ i))\<^sup>2) =
             (\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2 * x\<^sup>2)" by meson
  moreover have "(\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2 * x\<^sup>2) = x\<^sup>2 * (\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2)"
    by (metis (no_types) mult.commute sum_distrib_right)
  moreover have "sqrt(x\<^sup>2 * (\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2)) =
                 sqrt(x\<^sup>2) * sqrt (\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2)"
    using real_sqrt_mult by blast
  ultimately show ?thesis
    by(simp add: cpx_vec_length_def assms)
qed

locale state =
  fixes n:: nat and v:: "complex mat"
  assumes is_column [simp]: "dim_col v = 1"
    and dim_row [simp]: "dim_row v = 2^n"
    and is_normal [simp]: "\<parallel>col v 0\<parallel> = 1"

text\<open>
Below the natural number n codes for the dimension of the complex vector space whose elements of norm
1 we call states.
\<close>

lemma unit_vec_of_right_length_is_state [simp]:
  assumes "i < 2^n"
  shows "unit_vec (2^n) i \<in> {v| n v::complex vec. dim_vec v = 2^n \<and> \<parallel>v\<parallel> = 1}"
proof-
  have "dim_vec (unit_vec (2^n) i) = 2^n"
    by simp
  moreover have "\<parallel>unit_vec (2^n) i\<parallel> = 1"
    using assms by simp
  ultimately show ?thesis
    by simp
qed

definition state_qbit :: "nat \<Rightarrow> complex vec set" where
"state_qbit n \<equiv> {v| v:: complex vec. dim_vec v = 2^n \<and> \<parallel>v\<parallel> = 1}"

lemma (in state) state_to_state_qbit [simp]:
  shows "col v 0 \<in> state_qbit n"
  using state_def state_qbit_def by simp

subsection "The Hermitian Conjugation"

text \<open>The Hermitian conjugate of a complex matrix is the complex conjugate of its transpose. \<close>

definition dagger :: "complex mat \<Rightarrow> complex mat" ("_\<^sup>\<dagger>") where
  "M\<^sup>\<dagger> \<equiv> mat (dim_col M) (dim_row M) (\<lambda>(i,j). cnj(M $$ (j,i)))"

text \<open>We introduce the type of complex square matrices.\<close>

typedef cpx_sqr_mat = "{M | M::complex mat. square_mat M}"
proof-
  have "square_mat (1\<^sub>m n)" for n
    using one_mat_def by simp
  thus ?thesis by blast
qed

definition cpx_sqr_mat_to_cpx_mat :: "cpx_sqr_mat => complex mat" where
"cpx_sqr_mat_to_cpx_mat M \<equiv> Rep_cpx_sqr_mat M"

text \<open>
We introduce a coercion from the type of complex square matrices to the type of complex
matrices.
\<close>

declare [[coercion cpx_sqr_mat_to_cpx_mat]]

lemma dim_row_of_dagger [simp]:
  "dim_row (M\<^sup>\<dagger>) = dim_col M"
  using dagger_def by simp

lemma dim_col_of_dagger [simp]:
  "dim_col (M\<^sup>\<dagger>) = dim_row M"
  using dagger_def by simp

lemma col_of_dagger [simp]:
  assumes "j < dim_row M"
  shows "col (M\<^sup>\<dagger>) j = vec (dim_col M) (\<lambda>i. cnj (M $$ (j,i)))"
  using assms col_def dagger_def by simp

lemma row_of_dagger [simp]:
  assumes "i < dim_col M"
  shows "row (M\<^sup>\<dagger>) i = vec (dim_row M) (\<lambda>j. cnj (M $$ (j,i)))"
  using assms row_def dagger_def by simp

lemma dagger_of_dagger_is_id:
  fixes M :: "complex Matrix.mat"
  shows "(M\<^sup>\<dagger>)\<^sup>\<dagger> = M"
proof
  show "dim_row ((M\<^sup>\<dagger>)\<^sup>\<dagger>) = dim_row M" by simp
  show "dim_col ((M\<^sup>\<dagger>)\<^sup>\<dagger>) = dim_col M" by simp
  fix i j assume a0:"i < dim_row M" and a1:"j < dim_col M"
  then show "(M\<^sup>\<dagger>)\<^sup>\<dagger> $$ (i,j) = M $$ (i,j)"
  proof-
    show ?thesis
      using dagger_def a0 a1 by auto
  qed
qed

lemma dagger_of_sqr_is_sqr [simp]:
  "square_mat ((M::cpx_sqr_mat)\<^sup>\<dagger>)"
proof-
  have "square_mat M"
    using cpx_sqr_mat_to_cpx_mat_def Rep_cpx_sqr_mat by simp
  then have "dim_row M = dim_col M" by simp
  then have "dim_col (M\<^sup>\<dagger>) = dim_row (M\<^sup>\<dagger>)" by simp
  thus "square_mat (M\<^sup>\<dagger>)" by simp
qed

lemma dagger_of_id_is_id [simp]:
  "(1\<^sub>m n)\<^sup>\<dagger> = 1\<^sub>m n"
  using dagger_def one_mat_def by auto

subsection "Unitary Matrices and Quantum Gates"

definition unitary :: "complex mat \<Rightarrow> bool" where
"unitary M \<equiv> (M\<^sup>\<dagger>) * M = 1\<^sub>m (dim_col M) \<and> M * (M\<^sup>\<dagger>) = 1\<^sub>m (dim_row M)"

lemma id_is_unitary [simp]:
  "unitary (1\<^sub>m n)"
  by (simp add: unitary_def)

locale gate =
  fixes n:: nat and A:: "complex mat"
  assumes dim_row [simp]: "dim_row A = 2^n"
    and square_mat [simp]: "square_mat A"
    and unitary [simp]: "unitary A"

text \<open>
We prove that a quantum gate is invertible and its inverse is given by its Hermitian conjugate.
\<close>

lemma mat_unitary_mat [intro]:
  assumes "unitary M"
  shows "inverts_mat M (M\<^sup>\<dagger>)"
  using assms by (simp add: unitary_def inverts_mat_def)

lemma unitary_mat_mat [intro]:
  assumes "unitary M"
  shows "inverts_mat (M\<^sup>\<dagger>) M"
  using assms by (simp add: unitary_def inverts_mat_def)

lemma (in gate) gate_is_inv:
  "invertible_mat A"
  using square_mat unitary invertible_mat_def by blast

subsection "Relations Between Complex Conjugation, Hermitian Conjugation, Transposition and Unitarity"

notation transpose_mat ("(_\<^sup>t)")

lemma col_tranpose [simp]:
  assumes "dim_row M = n" and "i < n"
  shows "col (M\<^sup>t) i = row M i"
proof
  show "dim_vec (col (M\<^sup>t) i) = dim_vec (row M i)"
    by (simp add: row_def col_def transpose_mat_def)
next
  show "\<And>j. j < dim_vec (row M i) \<Longrightarrow> col M\<^sup>t i $ j = row M i $ j"
    using assms by (simp add: transpose_mat_def)
qed

lemma row_transpose [simp]:
  assumes "dim_col M = n" and "i < n"
  shows "row (M\<^sup>t) i = col M i"
  using assms by simp

definition cpx_mat_cnj :: "complex mat \<Rightarrow> complex mat" ("(_\<^sup>\<star>)") where
"cpx_mat_cnj M \<equiv> mat (dim_row M) (dim_col M) (\<lambda>(i,j). cnj (M $$ (i,j)))"

lemma cpx_mat_cnj_id [simp]:
  "(1\<^sub>m n)\<^sup>\<star> = 1\<^sub>m n"
  by (auto simp: cpx_mat_cnj_def)

lemma cpx_mat_cnj_cnj [simp]:
  "(M\<^sup>\<star>)\<^sup>\<star> = M"
  by (auto simp: cpx_mat_cnj_def)

lemma dim_row_of_cjn_prod [simp]:
  "dim_row ((M\<^sup>\<star>) * (N\<^sup>\<star>)) = dim_row M"
  by (simp add: cpx_mat_cnj_def)

lemma dim_col_of_cjn_prod [simp]:
  "dim_col ((M\<^sup>\<star>) * (N\<^sup>\<star>)) = dim_col N"
  by (simp add: cpx_mat_cnj_def)

lemma cpx_mat_cnj_prod:
  assumes "dim_col M = dim_row N"
  shows "(M * N)\<^sup>\<star> = (M\<^sup>\<star>) * (N\<^sup>\<star>)"
proof
  show "dim_row (M * N)\<^sup>\<star> = dim_row ((M\<^sup>\<star>) * (N\<^sup>\<star>))"
    by (simp add: cpx_mat_cnj_def)
next
  show "dim_col ((M * N)\<^sup>\<star>) = dim_col ((M\<^sup>\<star>) * (N\<^sup>\<star>))"
    by (simp add: cpx_mat_cnj_def)
next
  fix i j::nat
  assume a1:"i < dim_row ((M\<^sup>\<star>) * (N\<^sup>\<star>))" and a2:"j < dim_col ((M\<^sup>\<star>) * (N\<^sup>\<star>))"
  then have "(M * N)\<^sup>\<star> $$ (i,j) = cnj (\<Sum>k<(dim_row N). M $$ (i,k) * N $$ (k,j))"
    using assms cpx_mat_cnj_def index_mat times_mat_def scalar_prod_def row_def col_def
dim_row_of_cjn_prod dim_col_of_cjn_prod
    by (smt case_prod_conv dim_col index_mult_mat(2) index_mult_mat(3) index_vec lessThan_atLeast0
        lessThan_iff sum.cong)
  also have "\<dots> = (\<Sum>k<(dim_row N). cnj(M $$ (i,k)) * cnj(N $$ (k,j)))" by simp
  also have "((M\<^sup>\<star>) * (N\<^sup>\<star>)) $$ (i,j) =
    (\<Sum>k<(dim_row N). cnj(M $$ (i,k)) * cnj(N $$ (k,j)))"
    using assms a1 a2 cpx_mat_cnj_def index_mat times_mat_def scalar_prod_def row_def col_def
    by (smt case_prod_conv dim_col dim_col_mat(1) dim_row_mat(1) index_vec lessThan_atLeast0
        lessThan_iff sum.cong)
  finally show "(M * N)\<^sup>\<star> $$ (i, j) = ((M\<^sup>\<star>) * (N\<^sup>\<star>)) $$ (i, j)" by simp
qed

lemma transpose_of_prod:
  fixes M N::"complex Matrix.mat"
  assumes "dim_col M = dim_row N"
  shows "(M * N)\<^sup>t = N\<^sup>t * (M\<^sup>t)"
proof
  fix i j::nat
  assume a0: "i < dim_row (N\<^sup>t * (M\<^sup>t))" and a1: "j < dim_col (N\<^sup>t * (M\<^sup>t))"
  then have "(M * N)\<^sup>t $$ (i,j) = (M * N) $$ (j,i)" by auto
  also have "... = (\<Sum>k<dim_row M\<^sup>t.  M $$ (j,k) * N $$ (k,i))"
    using assms a0 a1 by auto
  also have "... = (\<Sum>k<dim_row M\<^sup>t. N $$ (k,i) * M $$ (j,k))"
   by (simp add: semiring_normalization_rules(7))
  also have "... = (\<Sum>k<dim_row M\<^sup>t. ((N\<^sup>t) $$ (i,k)) * (M\<^sup>t) $$ (k,j))"
    using assms a0 a1 by auto
  finally show "((M * N)\<^sup>t) $$ (i,j) = (N\<^sup>t * (M\<^sup>t)) $$ (i,j)"
    using assms a0 a1 by auto
next
  show "dim_row ((M * N)\<^sup>t) = dim_row (N\<^sup>t * (M\<^sup>t))" by auto
next
  show "dim_col ((M * N)\<^sup>t) = dim_col (N\<^sup>t * (M\<^sup>t))" by auto
qed

lemma transpose_cnj_is_dagger [simp]:
  "(M\<^sup>t)\<^sup>\<star> = (M\<^sup>\<dagger>)"
proof
  show f1:"dim_row ((M\<^sup>t)\<^sup>\<star>) = dim_row (M\<^sup>\<dagger>)"
    by (simp add: cpx_mat_cnj_def transpose_mat_def dagger_def)
next
  show f2:"dim_col ((M\<^sup>t)\<^sup>\<star>) = dim_col (M\<^sup>\<dagger>)"
    by (simp add: cpx_mat_cnj_def transpose_mat_def dagger_def)
next
  fix i j::nat
  assume "i < dim_row M\<^sup>\<dagger>" and "j < dim_col M\<^sup>\<dagger>"
  then show "M\<^sup>t\<^sup>\<star> $$ (i, j) = M\<^sup>\<dagger> $$ (i, j)"
    by (simp add: cpx_mat_cnj_def transpose_mat_def dagger_def)
qed

lemma cnj_transpose_is_dagger [simp]:
  "(M\<^sup>\<star>)\<^sup>t = (M\<^sup>\<dagger>)"
proof
  show "dim_row ((M\<^sup>\<star>)\<^sup>t) = dim_row (M\<^sup>\<dagger>)"
    by (simp add: transpose_mat_def cpx_mat_cnj_def dagger_def)
next
  show "dim_col ((M\<^sup>\<star>)\<^sup>t) = dim_col (M\<^sup>\<dagger>)"
    by (simp add: transpose_mat_def cpx_mat_cnj_def dagger_def)
next
  fix i j::nat
  assume "i < dim_row M\<^sup>\<dagger>" and "j < dim_col M\<^sup>\<dagger>"
  then show "M\<^sup>\<star>\<^sup>t $$ (i, j) = M\<^sup>\<dagger> $$ (i, j)"
    by (simp add: transpose_mat_def cpx_mat_cnj_def dagger_def)
qed

lemma dagger_of_transpose_is_cnj [simp]:
  "(M\<^sup>t)\<^sup>\<dagger> = (M\<^sup>\<star>)"
  by (metis transpose_transpose transpose_cnj_is_dagger)

lemma dagger_of_prod:
  fixes M N::"complex Matrix.mat"
  assumes "dim_col M = dim_row N"
  shows "(M * N)\<^sup>\<dagger> = N\<^sup>\<dagger> * (M\<^sup>\<dagger>)"
proof-
  have "(M * N)\<^sup>\<dagger> = ((M * N)\<^sup>\<star>)\<^sup>t" by auto
  also have "... = ((M\<^sup>\<star>) * (N\<^sup>\<star>))\<^sup>t" using assms cpx_mat_cnj_prod by auto
  also have "... = (N\<^sup>\<star>)\<^sup>t * ((M\<^sup>\<star>)\<^sup>t)" using assms transpose_of_prod
    by (metis cnj_transpose_is_dagger dim_col_of_dagger dim_row_of_dagger index_transpose_mat(2) index_transpose_mat(3))
  finally show "(M * N)\<^sup>\<dagger> = N\<^sup>\<dagger> * (M\<^sup>\<dagger>)" by auto
qed

text \<open>The product of two quantum gates is a quantum gate.\<close>

lemma prod_of_gate_is_gate:
  assumes "gate n G1" and "gate n G2"
  shows "gate n (G1 * G2)"
proof
  show "dim_row (G1 * G2) = 2^n" using assms by (simp add: gate_def)
next
  show "square_mat (G1 * G2)"
    using assms gate.dim_row gate.square_mat by simp
next
  show "unitary (G1 * G2)"
  proof-
    have "((G1 * G2)\<^sup>\<dagger>) * (G1 * G2) = 1\<^sub>m (dim_col (G1 * G2))"
    proof-
      have f0: "G1 \<in> carrier_mat (2^n) (2^n) \<and> G2 \<in> carrier_mat (2^n) (2^n)
              \<and> G1\<^sup>\<dagger> \<in> carrier_mat (2^n) (2^n) \<and> G2\<^sup>\<dagger> \<in> carrier_mat (2^n) (2^n)
              \<and> G1 * G2 \<in> carrier_mat (2^n) (2^n)"
        using assms gate.dim_row gate.square_mat by auto
      have "((G1 * G2)\<^sup>\<dagger>) * (G1 * G2) = ((G2\<^sup>\<dagger>) * (G1\<^sup>\<dagger>)) * (G1 * G2)"
        using assms dagger_of_prod gate.dim_row gate.square_mat by simp
      also have "... = (G2\<^sup>\<dagger>) * ((G1\<^sup>\<dagger>) * (G1 * G2))"
        using assms f0 by auto
      also have "... = (G2\<^sup>\<dagger>) * (((G1\<^sup>\<dagger>) * G1) * G2)"
        using assms f0 f0 by auto
      also have "... = (G2\<^sup>\<dagger>) * ((1\<^sub>m (dim_col G1)) * G2)"
        using gate.unitary[of n G1] assms unitary_def[of G1] by simp
      also have "... = (G2\<^sup>\<dagger>) * ((1\<^sub>m (dim_col G2)) * G2)"
        using assms f0 by (metis carrier_matD(2))
      also have "... = (G2\<^sup>\<dagger>) * G2"
        using f0 by (metis carrier_matD(2) left_mult_one_mat)
      finally show "((G1 * G2)\<^sup>\<dagger>) * (G1 * G2) = 1\<^sub>m (dim_col (G1 * G2))"
        using assms gate.unitary unitary_def by simp
    qed
    moreover have "(G1 * G2) * ((G1 * G2)\<^sup>\<dagger>) = 1\<^sub>m (dim_row (G1 * G2))"
      using assms calculation
      by (smt carrier_matI dim_col_of_dagger dim_row_of_dagger gate.dim_row gate.square_mat index_mult_mat(2) index_mult_mat(3)
          mat_mult_left_right_inverse square_mat.elims(2))
    ultimately show ?thesis using unitary_def by simp
  qed
qed

lemma left_inv_of_unitary_transpose [simp]:
  assumes "unitary U"
  shows "(U\<^sup>t)\<^sup>\<dagger> * (U\<^sup>t) =  1\<^sub>m(dim_row U)"
proof -
  have "dim_col U = dim_row ((U\<^sup>t)\<^sup>\<star>)" by simp
  then have "(U * ((U\<^sup>t)\<^sup>\<star>))\<^sup>\<star> = (U\<^sup>\<star>) * (U\<^sup>t)"
    using cpx_mat_cnj_prod cpx_mat_cnj_cnj by presburger
  also have "\<dots> = (U\<^sup>t)\<^sup>\<dagger> * (U\<^sup>t)" by simp
  finally show ?thesis
    using assms by (metis transpose_cnj_is_dagger cpx_mat_cnj_id unitary_def)
qed

lemma right_inv_of_unitary_transpose [simp]:
  assumes "unitary U"
  shows "U\<^sup>t * ((U\<^sup>t)\<^sup>\<dagger>) = 1\<^sub>m(dim_col U)"
proof -
  have "dim_col ((U\<^sup>t)\<^sup>\<star>) = dim_row U" by simp
  then have "U\<^sup>t * ((U\<^sup>t)\<^sup>\<dagger>) = (((U\<^sup>t)\<^sup>\<star> * U)\<^sup>\<star>)"
    using cpx_mat_cnj_cnj cpx_mat_cnj_prod dagger_of_transpose_is_cnj by presburger
  also have "\<dots> = (U\<^sup>\<dagger> * U)\<^sup>\<star>" by simp
  finally show ?thesis
    using assms by (metis cpx_mat_cnj_id unitary_def)
qed

lemma transpose_of_unitary_is_unitary [simp]:
  assumes "unitary U"
  shows "unitary (U\<^sup>t)"
  using unitary_def assms left_inv_of_unitary_transpose right_inv_of_unitary_transpose by simp

subsection "The Inner Product"

text \<open>We introduce a coercion between complex vectors and (column) complex matrices.\<close>

definition ket_vec :: "complex vec \<Rightarrow> complex mat" ("|_\<rangle>") where
"|v\<rangle> \<equiv> mat (dim_vec v) 1 (\<lambda>(i,j). v $ i)"

lemma ket_vec_index [simp]:
  assumes "i < dim_vec v"
  shows "|v\<rangle> $$ (i,0) = v $ i"
  using assms ket_vec_def by simp

lemma ket_vec_col [simp]:
  "col |v\<rangle> 0 = v"
  by (auto simp: col_def ket_vec_def)

lemma smult_ket_vec [simp]:
  "|x \<cdot>\<^sub>v v\<rangle> = x \<cdot>\<^sub>m |v\<rangle>"
  by (auto simp: ket_vec_def)

lemma smult_vec_length_bis [simp]:
  assumes "x \<ge> 0"
  shows "\<parallel>col (complex_of_real(x) \<cdot>\<^sub>m |v\<rangle>) 0\<parallel> = x * \<parallel>v\<parallel>"
  using assms smult_ket_vec smult_vec_length ket_vec_col by metis

declare [[coercion ket_vec]]

definition row_vec :: "complex vec \<Rightarrow> complex mat" where
"row_vec v \<equiv> mat 1 (dim_vec v) (\<lambda>(i,j). v $ j)"

definition bra_vec :: "complex vec \<Rightarrow> complex mat" where
"bra_vec v \<equiv> (row_vec v)\<^sup>\<star>"

lemma row_bra_vec [simp]:
  "row (bra_vec v) 0 = vec (dim_vec v) (\<lambda>i. cnj(v $ i))"
  by (auto simp: row_def bra_vec_def cpx_mat_cnj_def row_vec_def)

text \<open>We introduce a definition called @{term "bra"} to see a vector as a column matrix.\<close>

definition bra :: "complex mat \<Rightarrow> complex mat" ("\<langle>_|") where
"\<langle>v| \<equiv> mat 1 (dim_row v) (\<lambda>(i,j). cnj(v $$ (j,i)))"

text \<open>The relation between @{term "bra"}, @{term "bra_vec"} and @{term "ket_vec"} is given as follows.\<close>

lemma bra_bra_vec [simp]:
  "bra (ket_vec v) = bra_vec v"
  by (auto simp: bra_def ket_vec_def bra_vec_def cpx_mat_cnj_def row_vec_def)

lemma row_bra [simp]:
  fixes v::"complex vec"
  shows "row \<langle>v| 0 = vec (dim_vec v) (\<lambda>i. cnj (v $ i))" by simp

text \<open>We introduce the inner product of two complex vectors in @{text "\<complex>\<^sup>n"}.\<close>

definition inner_prod :: "complex vec \<Rightarrow> complex vec \<Rightarrow> complex" ("\<langle>_|_\<rangle>") where
"inner_prod u v \<equiv> \<Sum> i \<in> {0..< dim_vec v}. cnj(u $ i) * (v $ i)"

lemma inner_prod_with_row_bra_vec [simp]:
  assumes "dim_vec u = dim_vec v"
  shows "\<langle>u|v\<rangle> = row (bra_vec u) 0 \<bullet> v"
  using assms inner_prod_def scalar_prod_def row_bra_vec index_vec
  by (smt lessThan_atLeast0 lessThan_iff sum.cong)

lemma inner_prod_with_row_bra_vec_col_ket_vec [simp]:
  assumes "dim_vec u = dim_vec v"
  shows "\<langle>u|v\<rangle> = (row \<langle>u| 0) \<bullet> (col |v\<rangle> 0)"
  using assms by (simp add: inner_prod_def scalar_prod_def)

lemma inner_prod_with_times_mat [simp]:
  assumes "dim_vec u = dim_vec v"
  shows "\<langle>u|v\<rangle> = (\<langle>u| * |v\<rangle>) $$ (0,0)"
  using assms inner_prod_with_row_bra_vec_col_ket_vec
  by (simp add: inner_prod_def times_mat_def ket_vec_def bra_def)

lemma orthogonal_unit_vec [simp]:
  assumes "i < n" and "j < n" and "i \<noteq> j"
  shows "\<langle>unit_vec n i|unit_vec n j\<rangle> = 0"
proof-
  have "\<langle>unit_vec n i|unit_vec n j\<rangle> = unit_vec n i \<bullet> unit_vec n j"
    using assms unit_vec_def inner_prod_def scalar_prod_def
    by (smt complex_cnj_zero index_unit_vec(3) index_vec inner_prod_with_row_bra_vec row_bra_vec
        scalar_prod_right_unit)
  thus ?thesis
    using assms scalar_prod_def unit_vec_def by simp
qed

text \<open>We prove that our inner product is linear in its second argument.\<close>

lemma inner_prod_is_linear [simp]:
  fixes u::"complex vec" and v::"nat \<Rightarrow> complex vec" and l::"nat \<Rightarrow> complex"
  assumes "\<forall>i\<in>{0, 1}. dim_vec u = dim_vec (v i)"
  shows "\<langle>u|l 0 \<cdot>\<^sub>v v 0 + l 1 \<cdot>\<^sub>v v 1\<rangle> = (\<Sum>i\<le>1. l i * \<langle>u|v i\<rangle>)"
proof -
  have f1:"dim_vec (l 0 \<cdot>\<^sub>v v 0 + l 1 \<cdot>\<^sub>v v 1) = dim_vec u"
    using assms by simp
  then have "\<langle>u|l 0 \<cdot>\<^sub>v v 0 + l 1 \<cdot>\<^sub>v v 1\<rangle> = (\<Sum>i\<in>{0 ..< dim_vec u}. cnj (u $ i) * ((l 0 \<cdot>\<^sub>v v 0 + l 1 \<cdot>\<^sub>v v 1) $ i))"
    by (simp add: inner_prod_def)
  also have "\<dots> = (\<Sum>i\<in>{0 ..< dim_vec u}. cnj (u $ i) * (l 0 * v 0 $ i + l 1 * v 1 $ i))"
    using assms by simp
  also have "\<dots> = l 0 * (\<Sum>i\<in>{0 ..< dim_vec u}. cnj(u $ i) * (v 0 $ i)) + l 1 * (\<Sum>i\<in>{0 ..< dim_vec u}. cnj(u $ i) * (v 1 $ i))"
    apply (auto simp: algebra_simps)
    by (simp add: sum.distrib sum_distrib_left)
  also have "\<dots> = l 0 * \<langle>u|v 0\<rangle> + l 1 * \<langle>u|v 1\<rangle>"
    using assms inner_prod_def by auto
  finally show ?thesis by simp
qed

lemma inner_prod_cnj:
  assumes "dim_vec u = dim_vec v"
  shows "\<langle>v|u\<rangle> = cnj (\<langle>u|v\<rangle>)"
  by (simp add: assms inner_prod_def algebra_simps)

lemma inner_prod_with_itself_Im [simp]:
  "Im (\<langle>u|u\<rangle>) = 0"
  using inner_prod_cnj by (metis Reals_cnj_iff complex_is_Real_iff)

lemma inner_prod_with_itself_real [simp]:
  "\<langle>u|u\<rangle> \<in> \<real>"
  using inner_prod_with_itself_Im by (simp add: complex_is_Real_iff)

lemma inner_prod_with_itself_eq0 [simp]:
  assumes "u = 0\<^sub>v (dim_vec u)"
  shows "\<langle>u|u\<rangle> = 0"
  using assms inner_prod_def zero_vec_def
  by (smt atLeastLessThan_iff complex_cnj_zero index_zero_vec(1) mult_zero_left sum.neutral)

lemma inner_prod_with_itself_Re:
  "Re (\<langle>u|u\<rangle>) \<ge> 0"
proof -
  have "Re (\<langle>u|u\<rangle>) = (\<Sum>i<dim_vec u. Re (cnj(u $ i) * (u $ i)))"
    by (simp add: inner_prod_def lessThan_atLeast0)
  moreover have "\<dots> = (\<Sum>i<dim_vec u. (Re (u $ i))\<^sup>2 + (Im (u $ i))\<^sup>2)"
    using complex_mult_cnj
    by (metis (no_types, lifting) Re_complex_of_real semiring_normalization_rules(7))
  ultimately show "Re (\<langle>u|u\<rangle>) \<ge> 0" by (simp add: sum_nonneg)
qed

lemma inner_prod_with_itself_nonneg_reals:
  fixes u::"complex vec"
  shows "\<langle>u|u\<rangle> \<in> nonneg_Reals"
  using inner_prod_with_itself_real inner_prod_with_itself_Re complex_nonneg_Reals_iff
inner_prod_with_itself_Im by auto

lemma inner_prod_with_itself_Re_non0:
  assumes "u \<noteq> 0\<^sub>v (dim_vec u)"
  shows "Re (\<langle>u|u\<rangle>) > 0"
proof -
  obtain i where a1:"i < dim_vec u" and "u $ i \<noteq> 0"
    using assms zero_vec_def by (metis dim_vec eq_vecI index_zero_vec(1))
  then have f1:"Re (cnj (u $ i) * (u $ i)) > 0"
    by (metis Re_complex_of_real complex_mult_cnj complex_neq_0 mult.commute)
  moreover have f2:"Re (\<langle>u|u\<rangle>) = (\<Sum>i<dim_vec u. Re (cnj(u $ i) * (u $ i)))"
    using inner_prod_def by (simp add: lessThan_atLeast0)
  moreover have f3:"\<forall>i<dim_vec u. Re (cnj(u $ i) * (u $ i)) \<ge> 0"
    using complex_mult_cnj by simp
  ultimately show ?thesis
    using a1 inner_prod_def lessThan_iff
    by (metis (no_types, lifting) finite_lessThan sum_pos2)
qed

lemma inner_prod_with_itself_nonneg_reals_non0:
  assumes "u \<noteq> 0\<^sub>v (dim_vec u)"
  shows "\<langle>u|u\<rangle> \<noteq> 0"
  using assms inner_prod_with_itself_Re_non0 by fastforce

lemma cpx_vec_length_inner_prod [simp]:
  "\<parallel>v\<parallel>\<^sup>2 = \<langle>v|v\<rangle>"
proof -
  have "\<parallel>v\<parallel>\<^sup>2 = (\<Sum>i<dim_vec v. (cmod (v $ i))\<^sup>2)"
    using cpx_vec_length_def complex_of_real_def
    by (metis (no_types, lifting) real_sqrt_power real_sqrt_unique sum_nonneg zero_le_power2)
  also have "\<dots> = (\<Sum>i<dim_vec v. cnj (v $ i) * (v $ i))"
    using complex_norm_square mult.commute by (smt of_real_sum sum.cong)
  finally show ?thesis
    using inner_prod_def by (simp add: lessThan_atLeast0)
qed

lemma inner_prod_csqrt [simp]:
  "csqrt \<langle>v|v\<rangle> = \<parallel>v\<parallel>"
  using inner_prod_with_itself_Re inner_prod_with_itself_Im csqrt_of_real_nonneg cpx_vec_length_def
  by (metis (no_types, lifting) Re_complex_of_real cpx_vec_length_inner_prod real_sqrt_ge_0_iff
      real_sqrt_unique sum_nonneg zero_le_power2)

subsection "Unitary Matrices and Length-Preservation"

subsubsection "Unitary Matrices are Length-Preserving"

text \<open>The bra-vector @{text "\<langle>A * v|"} is given by @{text "\<langle>v| * A\<^sup>\<dagger>"}$\<close>

lemma dagger_of_ket_is_bra:
  fixes v:: "complex vec"
  shows "( |v\<rangle> )\<^sup>\<dagger> = \<langle>v|"
  by (simp add: bra_def dagger_def ket_vec_def)

lemma bra_mat_on_vec:
  fixes v::"complex vec" and A::"complex mat"
  assumes "dim_col A = dim_vec v"
  shows "\<langle>A * v| = \<langle>v| * (A\<^sup>\<dagger>)"
proof
  show "dim_row \<langle>A * v| = dim_row (\<langle>v| * (A\<^sup>\<dagger>))"
    by (simp add: bra_def times_mat_def)
next
  show "dim_col \<langle>A * v| = dim_col (\<langle>v| * (A\<^sup>\<dagger>))"
    by (simp add: bra_def times_mat_def)
next
  fix i j::nat
  assume a1:"i < dim_row (\<langle>v| * (A\<^sup>\<dagger>))" and a2:"j < dim_col (\<langle>v| * (A\<^sup>\<dagger>))"
  then have "cnj((A * v) $$ (j,0)) = cnj (row A j \<bullet> v)"
    using bra_def times_mat_def ket_vec_col ket_vec_def by simp
  also have f7:"\<dots>= (\<Sum>i\<in>{0 ..< dim_vec v}. cnj(v $ i) * cnj(A $$ (j,i)))"
    using row_def scalar_prod_def cnj_sum complex_cnj_mult mult.commute
    by (smt assms index_vec lessThan_atLeast0 lessThan_iff sum.cong)
  moreover have f8:"(row \<langle>v| 0) \<bullet> (col (A\<^sup>\<dagger>) j) =
    vec (dim_vec v) (\<lambda>i. cnj (v $ i)) \<bullet> vec (dim_col A) (\<lambda>i. cnj (A $$ (j,i)))"
    using a2 by simp
  ultimately have "cnj((A * v) $$ (j,0)) = (row \<langle>v| 0) \<bullet> (col (A\<^sup>\<dagger>) j)"
    using assms scalar_prod_def
    by (smt dim_vec index_vec lessThan_atLeast0 lessThan_iff sum.cong)
  then have "\<langle>A * v| $$ (0,j) = (\<langle>v| * (A\<^sup>\<dagger>)) $$ (0,j)"
    using bra_def times_mat_def a2 by simp
  thus "\<langle>A * |v\<rangle>| $$ (i, j) = (\<langle>v| * (A\<^sup>\<dagger>)) $$ (i, j)"
    using a1 by (simp add: times_mat_def bra_def)
qed

lemma mat_on_ket:
  fixes v:: "complex vec" and A:: "complex mat"
  assumes "dim_col A = dim_vec v"
  shows "A * |v\<rangle> = |col (A * v) 0\<rangle>"
  using assms ket_vec_def by auto

lemma dagger_of_mat_on_ket:
  fixes v:: "complex vec" and A :: "complex mat"
  assumes "dim_col A = dim_vec v"
  shows "(A * |v\<rangle> )\<^sup>\<dagger> = \<langle>v| * (A\<^sup>\<dagger>)"
  using assms by (metis bra_mat_on_vec dagger_of_ket_is_bra mat_on_ket)

definition col_fst :: "'a mat \<Rightarrow> 'a vec" where
  "col_fst A = vec (dim_row A) (\<lambda> i. A $$ (i,0))"

lemma col_fst_is_col [simp]:
  "col_fst M = col M 0"
  by (simp add: col_def col_fst_def)

text \<open>
We need to declare @{term "col_fst"} as a coercion from matrices to vectors in order to see a column
matrix as a vector.
\<close>

declare
  [[coercion_delete ket_vec]]
  [[coercion col_fst]]

lemma unit_vec_to_col:
  assumes "dim_col A = n" and "i < n"
  shows "col A i = A * |unit_vec n i\<rangle>"
proof
  show "dim_vec (col A i) = dim_vec (A * |unit_vec n i\<rangle>)"
    using col_def times_mat_def by simp
next
  fix j::nat
  assume "j < dim_vec (col_fst (A * |unit_vec n i\<rangle>))"
  then show "col A i $ j = (A * |unit_vec n i\<rangle>) $ j"
    using assms times_mat_def ket_vec_def
    by (smt col_fst_is_col dim_col dim_col_mat(1) index_col index_mult_mat(1) index_mult_mat(2)
index_row(1) ket_vec_col less_numeral_extra(1) scalar_prod_right_unit)
qed

lemma mult_ket_vec_is_ket_vec_of_mult:
  fixes A::"complex mat" and v::"complex vec"
  assumes "dim_col A = dim_vec v"
  shows "|A * |v\<rangle> \<rangle> = A * |v\<rangle>"
  using assms ket_vec_def
  by (metis One_nat_def col_fst_is_col dim_col dim_col_mat(1) index_mult_mat(3) ket_vec_col less_Suc0
mat_col_eqI)

lemma unitary_is_sq_length_preserving [simp]:
  assumes "unitary U" and "dim_vec v = dim_col U"
  shows "\<parallel>U * |v\<rangle>\<parallel>\<^sup>2 = \<parallel>v\<parallel>\<^sup>2"
proof -
  have "\<langle>U * |v\<rangle>|U * |v\<rangle> \<rangle> = (\<langle>|v\<rangle>| * (U\<^sup>\<dagger>) * |U * |v\<rangle>\<rangle>) $$ (0,0)"
    using assms(2) bra_mat_on_vec
    by (metis inner_prod_with_times_mat mult_ket_vec_is_ket_vec_of_mult)
  then have "\<langle>U * |v\<rangle>|U * |v\<rangle> \<rangle> = (\<langle>|v\<rangle>| * (U\<^sup>\<dagger>) * (U * |v\<rangle>)) $$ (0,0)"
    using assms(2) mult_ket_vec_is_ket_vec_of_mult by simp
  moreover have f1:"dim_col \<langle>|v\<rangle>| = dim_vec v"
    using ket_vec_def bra_def by simp
  moreover have "dim_row (U\<^sup>\<dagger>) = dim_vec v"
    using assms(2) by simp
  ultimately have "\<langle>U * |v\<rangle>|U * |v\<rangle> \<rangle> = (\<langle>|v\<rangle>| * ((U\<^sup>\<dagger>) * U) * |v\<rangle>) $$ (0,0)"
    using assoc_mult_mat
    by(smt carrier_mat_triv dim_row_mat(1) dagger_def ket_vec_def mat_carrier times_mat_def)
  then have "\<langle>U * |v\<rangle>|U * |v\<rangle> \<rangle> = (\<langle>|v\<rangle>| * |v\<rangle>) $$ (0,0)"
    using assms f1 unitary_def by simp
  thus ?thesis
    using cpx_vec_length_inner_prod by(metis Re_complex_of_real inner_prod_with_times_mat)
qed

lemma col_ket_vec [simp]:
  assumes "dim_col M = 1"
  shows "|col M 0\<rangle> = M"
  using eq_matI assms ket_vec_def by auto

lemma state_col_ket_vec:
  assumes "state 1 v"
  shows "state 1 |col v 0\<rangle>"
  using assms by (simp add: state_def)

lemma col_ket_vec_index [simp]:
  assumes "i < dim_row v"
  shows "|col v 0\<rangle> $$ (i,0) = v $$ (i,0)"
  using assms ket_vec_def by (simp add: col_def)

lemma col_index_of_mat_col [simp]:
  assumes "dim_col v = 1" and "i < dim_row v"
  shows "col v 0 $ i = v $$ (i,0)"
  using assms by simp

lemma unitary_is_sq_length_preserving_bis [simp]:
  assumes "unitary U" and "dim_row v = dim_col U" and "dim_col v = 1"
  shows "\<parallel>col (U * v) 0\<parallel>\<^sup>2 = \<parallel>col v 0\<parallel>\<^sup>2"
proof -
  have "dim_vec (col v 0) = dim_col U"
    using assms(2) by simp
  then have "\<parallel>col_fst (U * |col v 0\<rangle>)\<parallel>\<^sup>2 = \<parallel>col v 0\<parallel>\<^sup>2"
    using unitary_is_sq_length_preserving[of "U" "col v 0"] assms(1) by simp
  thus ?thesis
    using assms(3) by simp
qed

text \<open>
A unitary matrix is length-preserving, i.e. it acts on a vector to produce another vector of the
same length.
\<close>

lemma unitary_is_length_preserving_bis [simp]:
  fixes U::"complex mat" and v::"complex mat"
  assumes "unitary U" and "dim_row v = dim_col U" and "dim_col v = 1"
  shows "\<parallel>col (U * v) 0\<parallel> = \<parallel>col v 0\<parallel>"
  using assms unitary_is_sq_length_preserving_bis
  by (metis cpx_vec_length_inner_prod inner_prod_csqrt of_real_hom.injectivity)

lemma unitary_is_length_preserving [simp]:
  fixes U:: "complex mat" and v:: "complex vec"
  assumes "unitary U" and "dim_vec v = dim_col U"
  shows "\<parallel>U * |v\<rangle>\<parallel> = \<parallel>v\<parallel>"
  using assms unitary_is_sq_length_preserving
  by (metis cpx_vec_length_inner_prod inner_prod_csqrt of_real_hom.injectivity)

subsubsection "Length-Preserving Matrices are Unitary"

lemma inverts_mat_sym:
  fixes A B:: "complex mat"
  assumes "inverts_mat A B" and "dim_row B = dim_col A" and "square_mat B"
  shows "inverts_mat B A"
proof-
  define n where d0:"n = dim_row B"
  have "A * B = 1\<^sub>m (dim_row A)" using assms(1) inverts_mat_def by auto
  moreover have "dim_col B = dim_col (A * B)" using times_mat_def by simp
  ultimately have "dim_col B = dim_row A" by simp
  then have c0:"A \<in> carrier_mat n n" using assms(2,3) d0 by auto
  have c1:"B \<in> carrier_mat n n" using assms(3) d0 by auto
  have f0:"A * B = 1\<^sub>m n" using inverts_mat_def c0 c1 assms(1) by auto
  have f1:"det B \<noteq> 0"
  proof
    assume "det B = 0"
    then have "\<exists>v. v \<in> carrier_vec n \<and> v \<noteq> 0\<^sub>v n \<and> B *\<^sub>v v = 0\<^sub>v n"
      using det_0_iff_vec_prod_zero assms(3) c1 by blast
    then obtain v where d1:"v \<in> carrier_vec n \<and> v \<noteq> 0\<^sub>v n \<and> B *\<^sub>v v = 0\<^sub>v n" by auto
    then have d2:"dim_vec v = n" by simp
    have "B * |v\<rangle> = |0\<^sub>v n\<rangle>"
    proof
      show "dim_row (B * |v\<rangle>) = dim_row |0\<^sub>v n\<rangle>" using ket_vec_def d0 by simp
    next
      show "dim_col (B * |v\<rangle>) = dim_col |0\<^sub>v n\<rangle>" using ket_vec_def d0 by simp
    next
      fix i j assume "i < dim_row |0\<^sub>v n\<rangle>" and "j < dim_col |0\<^sub>v n\<rangle>"
      then have f2:"i < n \<and> j = 0" using ket_vec_def by simp
      moreover have "vec (dim_row B) (($) v) = v" using d0 d1 by auto
      moreover have "(B *\<^sub>v v) $ i = (\<Sum>ia = 0..<dim_row B. row B i $ ia * v $ ia)"
        using d0 d2 f2 by (auto simp add: scalar_prod_def)
      ultimately show "(B * |v\<rangle>) $$ (i, j) = |0\<^sub>v n\<rangle> $$ (i, j)"
        using ket_vec_def d0 d1 times_mat_def mult_mat_vec_def by (auto simp add: scalar_prod_def)
    qed
    moreover have "|v\<rangle> \<in> carrier_mat n 1" using d2 ket_vec_def by simp
    ultimately have "(A * B) * |v\<rangle> = A * |0\<^sub>v n\<rangle>" using c0 c1 by simp
    then have f3:"|v\<rangle> = A * |0\<^sub>v n\<rangle>" using d2 f0 ket_vec_def by auto
    have "v = 0\<^sub>v n"
    proof
      show "dim_vec v = dim_vec (0\<^sub>v n)" using d2 by simp
    next
      fix i assume f4:"i < dim_vec (0\<^sub>v n)"
      then have "|v\<rangle> $$ (i,0) = v $ i" using d2 ket_vec_def by simp
      moreover have "(A * |0\<^sub>v n\<rangle>) $$ (i, 0) = 0"
        using ket_vec_def times_mat_def scalar_prod_def f4 c0 by auto
      ultimately show "v $ i = 0\<^sub>v n $ i" using f3 f4 by simp
    qed
    then show False using d1 by simp
  qed
  have f5:"adj_mat B \<in> carrier_mat n n \<and> B * adj_mat B = det B \<cdot>\<^sub>m 1\<^sub>m n" using c1 adj_mat by auto
  then have c2:"((1/det B) \<cdot>\<^sub>m adj_mat B) \<in> carrier_mat n n" by simp
  have f6:"B * ((1/det B) \<cdot>\<^sub>m adj_mat B) = 1\<^sub>m n" using c1 f1 f5 mult_smult_distrib[of "B"] by auto
  then have "A = (A * B) * ((1/det B) \<cdot>\<^sub>m adj_mat B)" using c0 c1 c2 by simp
  then have "A = (1/det B) \<cdot>\<^sub>m adj_mat B" using f0 c2 by auto
  then show ?thesis using c0 c1 f6 inverts_mat_def by auto
qed

lemma sum_of_unit_vec_length:
  fixes i j n:: nat and c:: complex
  assumes "i < n" and "j < n" and "i \<noteq> j"
  shows "\<parallel>unit_vec n i + c \<cdot>\<^sub>v unit_vec n j\<parallel>\<^sup>2 = 1 + cnj(c) * c"
proof-
  define v where d0:"v = unit_vec n i + c \<cdot>\<^sub>v unit_vec n j"
  have "\<forall>k<n. v $ k = (if k = i then 1 else (if k = j then c else 0))"
    using d0 assms(1,2,3) by auto
  then have "\<forall>k<n. cnj (v $ k) * v $ k = (if k = i then 1 else 0) + (if k = j then cnj(c) * c else 0)"
    using assms(3) by auto
  moreover have "\<parallel>v\<parallel>\<^sup>2 = (\<Sum>k = 0..<n. cnj (v $ k) * v $ k)"
    using d0 assms cpx_vec_length_inner_prod inner_prod_def by simp
  ultimately show ?thesis
    using d0 assms by (auto simp add: sum.distrib)
qed

lemma sum_of_unit_vec_to_col:
  assumes "dim_col A = n" and "i < n" and "j < n"
  shows "col A i + c \<cdot>\<^sub>v col A j = A * |unit_vec n i + c \<cdot>\<^sub>v unit_vec n j\<rangle>"
proof
  show "dim_vec (col A i + c \<cdot>\<^sub>v col A j) = dim_vec (col_fst (A * |unit_vec n i + c \<cdot>\<^sub>v unit_vec n j\<rangle>))"
    using assms(1) by auto
next
  fix k assume "k < dim_vec (col_fst (A * |unit_vec n i + c \<cdot>\<^sub>v unit_vec n j\<rangle>))"
  then have f0:"k < dim_row A" using assms(1) by auto
  have "(col A i + c \<cdot>\<^sub>v col A j) $ k = A $$ (k, i) + c * A $$ (k, j)"
    using f0 assms(1-3) by auto
  moreover have "(\<Sum>x<n. A $$ (k, x) * ((if x = i then 1 else 0) + c * (if x = j then 1 else 0))) =
                 (\<Sum>x<n. A $$ (k, x) * (if x = i then 1 else 0)) +
                 (\<Sum>x<n. A $$ (k, x) * c * (if x = j then 1 else 0))"
    by (auto simp add: sum.distrib algebra_simps)
  moreover have "\<forall>x<n. A $$ (k, x) * (if x = i then 1 else 0) = (if x = i then A $$ (k, x) else 0)"
    by simp
  moreover have "\<forall>x<n. A $$ (k, x) * c * (if x = j then 1 else 0) = (if x = j then A $$ (k, x) * c else 0)"
    by simp
  ultimately show "(col A i + c \<cdot>\<^sub>v col A j) $ k = col_fst (A * |unit_vec n i + c \<cdot>\<^sub>v unit_vec n j\<rangle>) $ k"
    using f0 assms(1-3) times_mat_def scalar_prod_def ket_vec_def by auto
qed

lemma inner_prod_is_sesquilinear:
  fixes u1 u2 v1 v2:: "complex vec" and c1 c2 c3 c4:: complex and n:: nat
  assumes "dim_vec u1 = n" and "dim_vec u2 = n" and "dim_vec v1 = n" and "dim_vec v2 = n"
  shows "\<langle>c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2|c3 \<cdot>\<^sub>v v1 + c4 \<cdot>\<^sub>v v2\<rangle> = cnj (c1) * c3 * \<langle>u1|v1\<rangle> + cnj (c2) * c3 * \<langle>u2|v1\<rangle> +
                                                 cnj (c1) * c4 * \<langle>u1|v2\<rangle> + cnj (c2) * c4 * \<langle>u2|v2\<rangle>"
proof-
  have "\<langle>c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2|c3 \<cdot>\<^sub>v v1 + c4 \<cdot>\<^sub>v v2\<rangle> = c3 * \<langle>c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2|v1\<rangle> + c4 * \<langle>c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2|v2\<rangle>"
    using inner_prod_is_linear[of "c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2" "\<lambda>i. if i = 0 then v1 else v2"
                                  "\<lambda>i. if i = 0 then c3 else c4"] assms
    by simp
  also have "... = c3 * cnj(\<langle>v1|c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2\<rangle>) + c4 * cnj(\<langle>v2|c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2\<rangle>)"
    using assms inner_prod_cnj[of "v1" "c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2"] inner_prod_cnj[of "v2" "c1 \<cdot>\<^sub>v u1 + c2 \<cdot>\<^sub>v u2"]
    by simp
  also have "... = c3 * cnj(c1 * \<langle>v1|u1\<rangle> + c2 * \<langle>v1|u2\<rangle>) + c4 * cnj(c1 * \<langle>v2|u1\<rangle> + c2 * \<langle>v2|u2\<rangle>)"
    using inner_prod_is_linear[of "v1" "\<lambda>i. if i = 0 then u1 else u2" "\<lambda>i. if i = 0 then c1 else c2"]
          inner_prod_is_linear[of "v2" "\<lambda>i. if i = 0 then u1 else u2" "\<lambda>i. if i = 0 then c1 else c2"] assms
    by simp
  also have "... = c3 * (cnj(c1) * \<langle>u1|v1\<rangle> + cnj(c2) * \<langle>u2|v1\<rangle>) +
                   c4 * (cnj(c1) * \<langle>u1|v2\<rangle> + cnj(c2) * \<langle>u2|v2\<rangle>)"
    using inner_prod_cnj[of "v1" "u1"] inner_prod_cnj[of "v1" "u2"]
          inner_prod_cnj[of "v2" "u1"] inner_prod_cnj[of "v2" "u2"] assms
    by simp
  finally show ?thesis
    by (auto simp add: algebra_simps)
qed

text \<open>
A length-preserving matrix is unitary. So, unitary matrices are exactly the length-preserving
matrices.
\<close>

lemma length_preserving_is_unitary:
  fixes U:: "complex mat"
  assumes "square_mat U" and "\<forall>v::complex vec. dim_vec v = dim_col U \<longrightarrow> \<parallel>U * |v\<rangle>\<parallel> = \<parallel>v\<parallel>"
  shows "unitary U"
proof-
  define n where "n = dim_col U"
  then have c0:"U \<in> carrier_mat n n" using assms(1) by auto
  then have c1:"U\<^sup>\<dagger> \<in> carrier_mat n n" using assms(1) dagger_def by auto
  have f0:"(U\<^sup>\<dagger>) * U = 1\<^sub>m (dim_col U)"
  proof
    show "dim_row (U\<^sup>\<dagger> * U) = dim_row (1\<^sub>m (dim_col U))" using c0 by simp
  next
    show "dim_col (U\<^sup>\<dagger> * U) = dim_col (1\<^sub>m (dim_col U))" using c0 by simp
  next
    fix i j assume "i < dim_row (1\<^sub>m (dim_col U))" and "j < dim_col (1\<^sub>m (dim_col U))"
    then have a0:"i < n \<and> j < n" using c0 by simp
    have f1:"\<And>l. l<n \<longrightarrow> (\<Sum>k<n. cnj (U $$ (k, l)) * U $$ (k, l)) = 1"
    proof
      fix l assume a1:"l<n"
      define v::"complex vec" where d1:"v = unit_vec n l"
      have "\<parallel>col U l\<parallel>\<^sup>2 = (\<Sum>k<n. cnj (U $$ (k, l)) * U $$ (k, l))"
        using c0 a1 cpx_vec_length_inner_prod inner_prod_def lessThan_atLeast0 by simp
      moreover have "\<parallel>col U l\<parallel>\<^sup>2 = \<parallel>v\<parallel>\<^sup>2" using c0 d1 a1 assms(2) unit_vec_to_col by simp
      moreover have "\<parallel>v\<parallel>\<^sup>2 = 1" using d1 a1 cpx_vec_length_inner_prod by simp
      ultimately show "(\<Sum>k<n. cnj (U $$ (k, l)) * U $$ (k, l)) = 1" by simp
    qed
    moreover have "i \<noteq> j \<longrightarrow> (\<Sum>k<n. cnj (U $$ (k, i)) * U $$ (k, j)) = 0"
    proof
      assume a2:"i \<noteq> j"
      define v1::"complex vec" where d1:"v1 = unit_vec n i + 1 \<cdot>\<^sub>v unit_vec n j"
      define v2::"complex vec" where d2:"v2 = unit_vec n i + \<i> \<cdot>\<^sub>v unit_vec n j"
      have "\<parallel>v1\<parallel>\<^sup>2 = 1 + cnj 1 * 1" using d1 a0 a2 sum_of_unit_vec_length by blast
      then have "\<parallel>v1\<parallel>\<^sup>2 = 2"
        by (metis complex_cnj_one cpx_vec_length_inner_prod mult.left_neutral of_real_eq_iff
            of_real_numeral one_add_one)
      then have "\<parallel>U * |v1\<rangle>\<parallel>\<^sup>2 = 2" using c0 d1 assms(2) unit_vec_to_col by simp
      moreover have "col U i + 1 \<cdot>\<^sub>v col U j = U * |v1\<rangle>"
        using c0 d1 a0 sum_of_unit_vec_to_col by blast
      moreover have "col U i + 1 \<cdot>\<^sub>v col U j = col U i + col U j" by simp
      ultimately have "\<langle>col U i + col U j|col U i + col U j\<rangle> = 2"
        using cpx_vec_length_inner_prod by (metis of_real_numeral)
      moreover have "\<langle>col U i + col U j|col U i + col U j\<rangle> =
               \<langle>col U i|col U i\<rangle> + \<langle>col U j|col U i\<rangle> + \<langle>col U i|col U j\<rangle> + \<langle>col U j|col U j\<rangle>"
        using inner_prod_is_sesquilinear[of "col U i" "dim_row U" "col U j" "col U i" "col U j" "1" "1" "1" "1"]
        by simp
      ultimately have f2:"\<langle>col U j|col U i\<rangle> + \<langle>col U i|col U j\<rangle> = 0"
        using c0 a0 f1 inner_prod_def lessThan_atLeast0 by simp

      have "\<parallel>v2\<parallel>\<^sup>2 = 1 + cnj \<i> * \<i>" using a0 a2 d2 sum_of_unit_vec_length by simp
      then have "\<parallel>v2\<parallel>\<^sup>2 = 2"
        by (metis Re_complex_of_real complex_norm_square mult.commute norm_ii numeral_Bit0
            numeral_One numeral_eq_one_iff of_real_numeral one_power2)
      moreover have "\<parallel>U * |v2\<rangle>\<parallel>\<^sup>2 = \<parallel>v2\<parallel>\<^sup>2" using c0 d2 assms(2) unit_vec_to_col by simp
      moreover have "\<langle>col U i + \<i> \<cdot>\<^sub>v col U j|col U i + \<i> \<cdot>\<^sub>v col U j\<rangle> = \<parallel>U * |v2\<rangle>\<parallel>\<^sup>2"
        using c0 a0 d2 sum_of_unit_vec_to_col cpx_vec_length_inner_prod by auto
      moreover have "\<langle>col U i + \<i> \<cdot>\<^sub>v col U j|col U i + \<i> \<cdot>\<^sub>v col U j\<rangle> =
                     \<langle>col U i|col U i\<rangle> + (-\<i>) * \<langle>col U j|col U i\<rangle> + \<i> * \<langle>col U i|col U j\<rangle> + \<langle>col U j|col U j\<rangle>"
        using inner_prod_is_sesquilinear[of "col U i" "dim_row U" "col U j" "col U i" "col U j" "1" "\<i>" "1" "\<i>"]
        by simp
      ultimately have "\<langle>col U j|col U i\<rangle> - \<langle>col U i|col U j\<rangle> = 0"
        using c0 a0 f1 inner_prod_def lessThan_atLeast0 by auto
      then show "(\<Sum>k<n. cnj (U $$ (k, i)) * U $$ (k, j)) = 0"
        using c0 a0 f2 lessThan_atLeast0 inner_prod_def by auto
    qed
    ultimately show "(U\<^sup>\<dagger> * U) $$ (i, j) = 1\<^sub>m (dim_col U) $$ (i, j)"
      using c0 assms(1) a0 one_mat_def dagger_def by auto
qed
  then have "(U\<^sup>\<dagger>) * U = 1\<^sub>m n" using c0 by simp
  then have "inverts_mat (U\<^sup>\<dagger>) U" using c1 inverts_mat_def by auto
  then have "inverts_mat U (U\<^sup>\<dagger>)" using c0 c1 inverts_mat_sym by simp
  then have "U * (U\<^sup>\<dagger>) = 1\<^sub>m (dim_row U)" using c0 inverts_mat_def by auto
  then show ?thesis using f0 unitary_def by simp
qed

lemma inner_prod_with_unitary_mat [simp]:
  assumes "unitary U" and "dim_vec u = dim_col U" and "dim_vec v = dim_col U"
  shows "\<langle>U * |u\<rangle>|U * |v\<rangle>\<rangle> = \<langle>u|v\<rangle>"
proof -
  have f1:"\<langle>U * |u\<rangle>|U * |v\<rangle>\<rangle> = (\<langle>|u\<rangle>| * (U\<^sup>\<dagger>) * U * |v\<rangle>) $$ (0,0)"
    using assms(2-3) bra_mat_on_vec mult_ket_vec_is_ket_vec_of_mult
    by (smt assoc_mult_mat carrier_mat_triv col_fst_def dim_vec dim_col_of_dagger index_mult_mat(2)
        index_mult_mat(3) inner_prod_with_times_mat ket_vec_def mat_carrier)
  moreover have f2:"\<langle>|u\<rangle>| \<in> carrier_mat 1 (dim_vec v)"
    using bra_def ket_vec_def assms(2-3) by simp
  moreover have f3:"U\<^sup>\<dagger> \<in> carrier_mat (dim_col U) (dim_row U)"
    using dagger_def by simp
  ultimately have "\<langle>U * |u\<rangle>|U * |v\<rangle>\<rangle> = (\<langle>|u\<rangle>| * (U\<^sup>\<dagger> * U) * |v\<rangle>) $$ (0,0)"
    using assms(3) assoc_mult_mat by (metis carrier_mat_triv)
  also have "\<dots> = (\<langle>|u\<rangle>| * |v\<rangle>) $$ (0,0)"
    using assms(1) unitary_def
    by (simp add: assms(2) bra_def ket_vec_def)
  finally show ?thesis
    using assms(2-3) inner_prod_with_times_mat by presburger
qed

text \<open>As a consequence we prove that columns and rows of a unitary matrix are orthonormal vectors.\<close>

lemma unitary_unit_col [simp]:
  assumes "unitary U" and "dim_col U = n" and "i < n"
  shows "\<parallel>col U i\<parallel> = 1"
  using assms unit_vec_to_col unitary_is_length_preserving by simp

lemma unitary_unit_row [simp]:
  assumes "unitary U" and "dim_row U = n" and "i < n"
  shows "\<parallel>row U i\<parallel> = 1"
proof -
  have "row U i = col (U\<^sup>t) i"
    using  assms(2-3) by simp
  thus ?thesis
    using assms transpose_of_unitary_is_unitary unitary_unit_col
    by (metis index_transpose_mat(3))
qed

lemma orthogonal_col_of_unitary [simp]:
  assumes "unitary U" and "dim_col U = n" and "i < n" and "j < n" and "i \<noteq> j"
  shows "\<langle>col U i|col U j\<rangle> = 0"
proof -
  have "\<langle>col U i|col U j\<rangle> = \<langle>U * |unit_vec n i\<rangle>| U * |unit_vec n j\<rangle>\<rangle>"
    using assms(2-4) unit_vec_to_col by simp
  also have "\<dots> = \<langle>unit_vec n i |unit_vec n j\<rangle>"
    using assms(1-2) inner_prod_with_unitary_mat index_unit_vec(3) by simp
  finally show ?thesis
    using assms(3-5) by simp
qed

lemma orthogonal_row_of_unitary [simp]:
  fixes U::"complex mat"
  assumes "unitary U" and "dim_row U = n" and "i < n" and "j < n" and "i \<noteq> j"
  shows "\<langle>row U i|row U j\<rangle> = 0"
  using assms orthogonal_col_of_unitary transpose_of_unitary_is_unitary col_transpose
  by (metis index_transpose_mat(3))

text\<open>
As a consequence, we prove that a quantum gate acting on a state of a system of n qubits give
another state of that same system.
\<close>

lemma gate_on_state_is_state [intro, simp]:
  assumes a1:"gate n A" and a2:"state n v"
  shows "state n (A * v)"
proof
  show "dim_row (A * v) = 2^n"
    using gate_def state_def a1 by simp
next
  show "dim_col (A * v) = 1"
    using state_def a2 by simp
next
  have "square_mat A"
    using a1 gate_def by simp
  then have "dim_col A = 2^n"
    using a1 gate.dim_row by simp
  then have "dim_col A = dim_row v"
    using a2 state.dim_row by simp
  then have "\<parallel>col (A * v) 0\<parallel> = \<parallel>col v 0\<parallel>"
    using unitary_is_length_preserving_bis assms gate_def state_def by simp
  thus"\<parallel>col (A * v) 0\<parallel> = 1"
    using a2 state.is_normal by simp
qed

subsection \<open>A Few Well-known Quantum Gates\<close>

text \<open>
Any unitary operation on n qubits can be implemented exactly by composing single qubits and
CNOT-gates (controlled-NOT gates). However, no straightforward method is known to implement these
gates in a fashion which is resistant to errors. But, the Hadamard gate, the phase gate, the
CNOT-gate and the @{text "\<pi>/8"} gate are also universal for quantum computations, i.e. any quantum circuit on
n qubits can be approximated to an arbitrary accuracy by using only these gates, and these gates can
be implemented in a fault-tolerant way.
\<close>

text \<open>We introduce a coercion from real matrices to complex matrices.\<close>

definition real_to_cpx_mat:: "real mat \<Rightarrow> complex mat" where
"real_to_cpx_mat A \<equiv> mat (dim_row A) (dim_col A) (\<lambda>(i,j). A $$ (i,j))"

text \<open>Our first quantum gate: the identity matrix! Arguably, not a very interesting one though!\<close>

definition Id :: "nat \<Rightarrow> complex mat" where
"Id n \<equiv> 1\<^sub>m (2^n)"

lemma id_is_gate [simp]:
  "gate n (Id n)"
proof
  show "dim_row (Id n) = 2^n"
    using Id_def by simp
next
  show "square_mat (Id n)"
    using Id_def by simp
next
  show "unitary (Id n)"
    by (simp add: Id_def)
qed

text \<open>More interesting: the Pauli matrices.\<close>

definition X ::"complex mat" where
"X \<equiv> mat 2 2 (\<lambda>(i,j). if i=j then 0 else 1)"

text\<open>
Be aware that @{text "gate n A"} means that the matrix A has dimension @{text "2^n * 2^n"}.
For instance, with this convention a 2 X 2 matrix A which is unitary satisfies @{text "gate 1 A"}
 but not @{text "gate 2 A"} as one might have been expected.
\<close>

lemma dagger_of_X [simp]:
  "X\<^sup>\<dagger> = X"
  using dagger_def by (simp add: X_def cong_mat)

lemma X_inv [simp]:
  "X * X = 1\<^sub>m 2"
  apply(simp add: X_def times_mat_def one_mat_def)
  apply(rule cong_mat)
  by(auto simp: scalar_prod_def)

lemma X_is_gate [simp]:
  "gate 1 X"
  apply(simp add: gate_def unitary_def)
  apply(simp add: X_def)
  done

definition Y ::"complex mat" where
"Y \<equiv> mat 2 2 (\<lambda>(i,j). if i=j then 0 else (if i=0 then -\<i> else \<i>))"

lemma dagger_of_Y [simp]:
  "Y\<^sup>\<dagger> = Y"
  using dagger_def by (simp add: Y_def cong_mat)

lemma Y_inv [simp]:
  "Y * Y = 1\<^sub>m 2"
  apply(simp add: Y_def times_mat_def one_mat_def)
  apply(rule cong_mat)
  by(auto simp: scalar_prod_def)

lemma Y_is_gate [simp]:
  "gate 1 Y"
  apply(simp add: gate_def unitary_def)
  apply(simp add: Y_def)
  done

definition Z ::"complex mat" where
"Z \<equiv> mat 2 2 (\<lambda>(i,j). if i\<noteq>j then 0 else (if i=0 then 1 else -1))"

lemma dagger_of_Z [simp]:
  "Z\<^sup>\<dagger> = Z"
  using dagger_def by (simp add: Z_def cong_mat)

lemma Z_inv [simp]:
  "Z * Z = 1\<^sub>m 2"
  apply(simp add: Z_def times_mat_def one_mat_def)
  apply(rule cong_mat)
  by(auto simp: scalar_prod_def)

lemma Z_is_gate [simp]:
  "gate 1 Z"
  apply(simp add: gate_def unitary_def)
  apply(simp add: Z_def)
  done

text \<open>The Hadamard gate\<close>

definition H ::"complex mat" where
"H \<equiv> 1/sqrt(2) \<cdot>\<^sub>m (mat 2 2 (\<lambda>(i,j). if i\<noteq>j then 1 else (if i=0 then 1 else -1)))"

lemma H_without_scalar_prod:
  "H = mat 2 2 (\<lambda>(i,j). if i\<noteq>j then 1/sqrt(2) else (if i=0 then 1/sqrt(2) else -(1/sqrt(2))))"
  using cong_mat by (auto simp: H_def)

lemma dagger_of_H [simp]:
  "H\<^sup>\<dagger> = H"
  using dagger_def by (auto simp: H_def cong_mat)

lemma H_inv [simp]:
  "H * H = 1\<^sub>m 2"
  apply(simp add: H_def times_mat_def one_mat_def)
  apply(rule cong_mat)
  by(auto simp: scalar_prod_def complex_eqI)

lemma H_is_gate [simp]:
  "gate 1 H"
  apply(simp add: gate_def unitary_def)
  apply(simp add: H_def)
  done

lemma H_values:
  fixes i j:: nat
  assumes "i < dim_row H" and "j < dim_col H" and "i \<noteq> 1 \<or> j \<noteq> 1"
  shows "H $$ (i,j) = 1/sqrt 2"
proof-
  have "i < 2"
    using assms(1) by (simp add: H_without_scalar_prod less_2_cases)
  moreover have "j < 2"
    using assms(2) by (simp add: H_without_scalar_prod less_2_cases)
  ultimately show ?thesis
    using assms(3) H_without_scalar_prod by(smt One_nat_def index_mat(1) less_2_cases old.prod.case)
qed

lemma H_values_right_bottom:
  fixes i j:: nat
  assumes "i = 1 \<and> j = 1"
  shows "H $$ (i,j) = - 1/sqrt 2"
  using assms by (simp add: H_without_scalar_prod)

text \<open>The controlled-NOT gate\<close>

definition CNOT ::"complex mat" where
"CNOT \<equiv> mat 4 4
  (\<lambda>(i,j). if i=0 \<and> j=0 then 1 else
    (if i=1 \<and> j=1 then 1 else
      (if i=2 \<and> j=3 then 1 else
        (if i=3 \<and> j=2 then 1 else 0))))"

lemma dagger_of_CNOT [simp]:
  "CNOT\<^sup>\<dagger> = CNOT"
  using dagger_def by (simp add: CNOT_def cong_mat)

lemma CNOT_inv [simp]:
  "CNOT * CNOT = 1\<^sub>m 4"
  apply(simp add: CNOT_def times_mat_def one_mat_def)
  apply(rule cong_mat)
  by(auto simp: scalar_prod_def)

lemma CNOT_is_gate [simp]:
  "gate 2 CNOT"
  apply(simp add: gate_def unitary_def)
  apply(simp add: CNOT_def)
  done

text \<open>The phase gate, also known as the S-gate\<close>

definition S ::"complex mat" where
"S \<equiv> mat 2 2 (\<lambda>(i,j). if i=0 \<and> j=0 then 1 else (if i=1 \<and> j=1 then \<i> else 0))"

text \<open>The @{text "\<pi>/8"} gate, also known as the T-gate\<close>

definition T ::"complex mat" where
"T \<equiv> mat 2 2 (\<lambda>(i,j). if i=0 \<and> j=0 then 1 else (if i=1 \<and> j=1 then exp(\<i>*(pi/4)) else 0))"

text \<open>A few relations between the Hadamard gate and the Pauli matrices\<close>

lemma HXH_is_Z [simp]:
  "H * X * H = Z"
  apply(simp add: X_def Z_def H_def times_mat_def)
  apply(rule cong_mat)
  by(auto simp add: scalar_prod_def complex_eqI)

lemma HYH_is_minusY [simp]:
  "H * Y * H = - Y"
  apply(simp add: Y_def H_def times_mat_def)
  apply(rule eq_matI)
  by(auto simp add: scalar_prod_def complex_eqI)

lemma HZH_is_X [simp]:
  shows "H * Z * H = X"
  apply(simp add: X_def Z_def H_def times_mat_def)
  apply(rule cong_mat)
  by(auto simp add: scalar_prod_def complex_eqI)

subsection \<open>The Bell States\<close>

text \<open>
We introduce below the so-called Bell states, also known as EPR pairs (EPR stands for Einstein,
Podolsky and Rosen).
\<close>

definition bell00 ::"complex mat" ("|\<beta>\<^sub>0\<^sub>0\<rangle>") where
"bell00 \<equiv> 1/sqrt(2) \<cdot>\<^sub>m |vec 4 (\<lambda>i. if i=0 \<or> i=3 then 1 else 0)\<rangle>"

definition bell01 ::"complex mat" ("|\<beta>\<^sub>0\<^sub>1\<rangle>") where
"bell01 \<equiv> 1/sqrt(2) \<cdot>\<^sub>m |vec 4 (\<lambda>i. if i=1 \<or> i=2 then 1 else 0)\<rangle>"

definition bell10 ::"complex mat" ("|\<beta>\<^sub>1\<^sub>0\<rangle>") where
"bell10 \<equiv> 1/sqrt(2) \<cdot>\<^sub>m |vec 4 (\<lambda>i. if i=0 then 1 else if i=3 then -1 else 0)\<rangle>"

definition bell11 ::"complex mat" ("|\<beta>\<^sub>1\<^sub>1\<rangle>") where
"bell11 \<equiv> 1/sqrt(2) \<cdot>\<^sub>m |vec 4 (\<lambda>i. if i=1 then 1 else if i=2 then -1 else 0)\<rangle>"

lemma
  shows bell00_is_state [simp]:"state 2 |\<beta>\<^sub>0\<^sub>0\<rangle>" and bell01_is_state [simp]:"state 2 |\<beta>\<^sub>0\<^sub>1\<rangle>" and
    bell10_is_state [simp]:"state 2 |\<beta>\<^sub>1\<^sub>0\<rangle>" and bell11_is_state [simp]:"state 2 |\<beta>\<^sub>1\<^sub>1\<rangle>"
     apply (auto simp: state_def bell00_def bell01_def bell10_def bell11_def ket_vec_def)
     apply (auto simp: cpx_vec_length_def Set_Interval.lessThan_atLeast0 cmod_def power2_eq_square)
  done

lemma bell00_index [simp]:
  shows "|\<beta>\<^sub>0\<^sub>0\<rangle> $$ (0,0) = 1/sqrt 2" and "|\<beta>\<^sub>0\<^sub>0\<rangle> $$ (1,0) = 0" and "|\<beta>\<^sub>0\<^sub>0\<rangle> $$ (2,0) = 0" and
    "|\<beta>\<^sub>0\<^sub>0\<rangle> $$ (3,0) = 1/sqrt 2"
     apply (auto simp: bell00_def ket_vec_def)
  done

lemma bell01_index [simp]:
  shows "|\<beta>\<^sub>0\<^sub>1\<rangle> $$ (0,0) = 0" and "|\<beta>\<^sub>0\<^sub>1\<rangle> $$ (1,0) = 1/sqrt 2" and "|\<beta>\<^sub>0\<^sub>1\<rangle> $$ (2,0) = 1/sqrt 2" and
    "|\<beta>\<^sub>0\<^sub>1\<rangle> $$ (3,0) = 0"
     apply (auto simp: bell01_def ket_vec_def)
  done

lemma bell10_index [simp]:
  shows "|\<beta>\<^sub>1\<^sub>0\<rangle> $$ (0,0) = 1/sqrt 2" and "|\<beta>\<^sub>1\<^sub>0\<rangle> $$ (1,0) = 0" and "|\<beta>\<^sub>1\<^sub>0\<rangle> $$ (2,0) = 0" and
    "|\<beta>\<^sub>1\<^sub>0\<rangle> $$ (3,0) = - 1/sqrt 2"
     apply (auto simp: bell10_def ket_vec_def)
  done

lemma bell_11_index [simp]:
  shows "|\<beta>\<^sub>1\<^sub>1\<rangle> $$ (0,0) = 0" and "|\<beta>\<^sub>1\<^sub>1\<rangle> $$ (1,0) = 1/sqrt 2" and "|\<beta>\<^sub>1\<^sub>1\<rangle> $$ (2,0) = - 1/sqrt 2" and
    "|\<beta>\<^sub>1\<^sub>1\<rangle> $$ (3,0) = 0"
     apply (auto simp: bell11_def ket_vec_def)
  done

subsection \<open>The Bitwise Inner Product\<close>

definition bitwise_inner_prod:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"bitwise_inner_prod n i j = (\<Sum>k\<in>{0..<n}. (bin_rep n i) ! k * (bin_rep n j) ! k)"

abbreviation bip:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" ("_ \<cdot>\<^bsub>_\<^esub>  _") where
"bip i n j \<equiv> bitwise_inner_prod n i j"

lemma bitwise_inner_prod_fst_el_0:
  assumes "i < 2^n \<or> j < 2^n"
  shows "(i \<cdot>\<^bsub>Suc n\<^esub> j) = (i mod 2^n) \<cdot>\<^bsub>n\<^esub> (j mod 2^n)"
proof-
  have "bip i (Suc n) j = (\<Sum>k\<in>{0..<(Suc n)}. (bin_rep (Suc n) i) ! k * (bin_rep (Suc n) j) ! k)"
    using bitwise_inner_prod_def by simp
  also have "... = bin_rep (Suc n) i ! 0 * bin_rep (Suc n) j ! 0 +
             (\<Sum>k\<in>{1..<(Suc n)}. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k)"
    by (simp add: sum.atLeast_Suc_lessThan)
  also have "... = (\<Sum>k\<in>{1..<(Suc n)}. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k)"
    using bin_rep_index_0[of i n] bin_rep_index_0[of j n] assms by auto
  also have "... = (\<Sum>k\<in>{0..<n}. bin_rep (Suc n) i !(k+1) * bin_rep (Suc n) j ! (k+1))"
     using sum.shift_bounds_Suc_ivl[of "\<lambda>k. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k" "0" "n"]
     by (metis (no_types, lifting) One_nat_def add.commute plus_1_eq_Suc sum.cong)
  finally have "bip i (Suc n) j = (\<Sum>k\<in>{0..<n}. bin_rep (Suc n) i ! (k+1) * bin_rep (Suc n) j ! (k+1))"
    by simp
  moreover have "k\<in>{0..n} \<longrightarrow> bin_rep (Suc n) i ! (k+1) = bin_rep n (i mod 2^n) ! k" for k
    using bin_rep_def by (simp add: bin_rep_aux_neq_nil)
  moreover have "k\<in>{0..n} \<longrightarrow> bin_rep (Suc n) j !(k+1) = bin_rep n (j mod 2^n) ! k" for k
    using bin_rep_def by (simp add: bin_rep_aux_neq_nil)
  ultimately show ?thesis
    using assms bin_rep_index_0 bitwise_inner_prod_def by simp
qed

lemma bitwise_inner_prod_fst_el_is_1:
  fixes n i j:: nat
  assumes "i \<ge> 2^n \<and> j \<ge> 2^n" and "i < 2^(n+1) \<and> j < 2^(n+1)"
  shows "(i \<cdot>\<^bsub>(n+1)\<^esub> j) = 1 + ((i mod 2^n) \<cdot>\<^bsub>n\<^esub> (j mod 2^n))"
proof-
  have "bip i (Suc n) j = (\<Sum>k\<in>{0..<(Suc n)}. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k)"
    using bitwise_inner_prod_def by simp
  also have "... = bin_rep (Suc n) i ! 0 * bin_rep (Suc n) j ! 0 +
            (\<Sum>k\<in>{1..<(Suc n)}. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k)"
    by (simp add: sum.atLeast_Suc_lessThan)
  also have "... = 1 + (\<Sum>k\<in>{1..<(Suc n)}. bin_rep (Suc n) i ! k * bin_rep (Suc n) j ! k)"
    using bin_rep_index_0_geq[of n i] bin_rep_index_0_geq[of n j] assms by simp
  also have "... = 1 + (\<Sum>k \<in> {0..<n}. bin_rep (Suc n) i ! (k+1) * bin_rep (Suc n) j ! (k+1))"
    using sum.shift_bounds_Suc_ivl[of "\<lambda>k. (bin_rep (Suc n) i)!k * (bin_rep (Suc n) j)!k" "0" "n"]
    by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 sum.cong)
  finally have f0:"bip i (Suc n) j = 1 + (\<Sum>k\<in>{0..<n}. bin_rep (Suc n) i ! (k+1) * bin_rep (Suc n) j ! (k+1))"
    by simp
  moreover have "k\<in>{0..n} \<longrightarrow> bin_rep (Suc n) i ! (k+1) = bin_rep n (i mod 2^n) ! k
\<and> bin_rep (Suc n) j ! (k+1) = bin_rep n (j mod 2^n) ! k" for k
    using bin_rep_def by(metis Suc_eq_plus1 bin_rep_aux.simps(2) bin_rep_aux_neq_nil butlast.simps(2) nth_Cons_Suc)
  ultimately show ?thesis
    using bitwise_inner_prod_def by simp
qed

lemma bitwise_inner_prod_with_zero:
  assumes "m < 2^n"
  shows "(0 \<cdot>\<^bsub>n\<^esub>  m) = 0"
proof-
  have "(0 \<cdot>\<^bsub>n\<^esub>  m) = (\<Sum>j\<in>{0..<n}. bin_rep n 0 ! j * bin_rep n m ! j)"
    using bitwise_inner_prod_def by simp
  moreover have "(\<Sum>j\<in>{0..<n}. bin_rep n 0 ! j * bin_rep n m ! j)
               = (\<Sum>j\<in>{0..<n}. 0 * (bin_rep n m) ! j)"
    by (simp add: bin_rep_index)
  ultimately show "?thesis"
    by simp
qed

(*
Biblio:

@book{MikeandIke,
  author = {Nielsen, Michael A. and Chuang, Isaac L.},
  publisher = {Cambridge University Press},
  title = {Quantum Computation and Quantum Information},
  year = 2010
}
*)

end


theory Intervals
imports "~~/src/HOL/Library/Float"
        "~~/src/HOL/Library/Set_Algebras"
begin

(* I define my own interval type here. I then define the basic arithmetic operations on intervals.
   This way, I can define and evaluate interval polynomials. *)
typedef (overloaded) 'a interval = "{(a::'a::order, b). a \<le> b}"
  by auto

setup_lifting type_definition_interval

lift_definition Ivl::"'a::order \<Rightarrow> 'a \<Rightarrow> 'a interval"
is "\<lambda>a b. (a, max a b)"
  by (simp add: max_def)

lift_definition proc_of::"'a::order interval \<Rightarrow> 'a \<times> 'a"
is Rep_interval .

lift_definition lower::"('a::order) interval \<Rightarrow> 'a" is fst .
lift_definition upper::"('a::order) interval \<Rightarrow> 'a" is snd .

definition width :: "'a::{order,minus} interval \<Rightarrow> 'a"
where "width i = upper i - lower i"

definition mid :: "float interval \<Rightarrow> float"
where "mid i = (lower i + upper i) * Float 1 (-1)"

definition set_of :: "'a::order interval \<Rightarrow> 'a set"
where "set_of i = {lower i..upper i}"

definition interval_of :: "'a::order \<Rightarrow> 'a interval"
where "interval_of x = Ivl x x"

definition interval_map :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a interval \<Rightarrow> 'b interval"
where "interval_map f i = Ivl (f (lower i)) (f (upper i))"

definition interval_union :: "'a::order interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
where "interval_union a b = Ivl (min (lower a) (lower b)) (max (upper a) (upper b))"

fun interval_list_union :: "'a::linorder interval list \<Rightarrow> 'a interval"
where "interval_list_union [] = undefined"
    | "interval_list_union [I] = I"
    | "interval_list_union (I#Is) = interval_union I (interval_list_union Is)"

lemmas [simp] = proc_of_def

lemma lower_le_upper:
shows "lower i \<le> upper i"
proof-
  obtain y where i_def: "i = Abs_interval y" and y_def: "y \<in> {(a, b). a \<le> b}"
    using Abs_interval_cases by auto
  hence "fst y \<le> snd y"
    by auto
  thus ?thesis
    by (simp add: i_def interval.Abs_interval_inverse[OF y_def] lower_def upper_def)
qed

lemma lower_Ivl[simp]:
shows "lower (Ivl a b) = a"
by (simp add: Ivl.rep_eq lower.rep_eq)

lemma upper_Ivl_a[simp]:
assumes "b \<le> a"
shows "upper (Ivl a b) = a"
using assms
by (simp add: upper_def Ivl.rep_eq max_def)

lemma upper_Ivl_b[simp]:
assumes "a \<le> b"
shows "upper (Ivl a b) = b"
using assms
by (simp add: upper_def Ivl.rep_eq max_def)

lemma lower_refl[simp]:
shows "lower (Ivl a a) = a"
by (simp add: Ivl.rep_eq lower.rep_eq)

lemma upper_refl[simp]:
shows "upper (Ivl a a) = a"
by (simp add: Ivl.rep_eq max_def upper.rep_eq)

lemma upper_Ivl_upper_lower[simp]:
shows "upper (Ivl (lower I) (upper I)) = upper I"
using lower_le_upper upper_Ivl_b
by auto

lemma upper_Ivl_upper_lower_real[simp]:
fixes I::"float interval"
shows "upper (Ivl (real_of_float (lower I)) (real_of_float(upper I))) = real_of_float (upper I)"
using lower_le_upper less_eq_float.rep_eq upper_Ivl_b
by blast

lemma set_of_interval_union:
fixes A::"'a::linorder interval"
shows "set_of A \<union> set_of B \<subseteq> set_of (interval_union A B)"
by (auto simp add: min_def max_def set_of_def interval_union_def)

lemma interval_union_commute:
fixes A::"'a::linorder interval"
shows "interval_union A B = interval_union B A"
by (auto simp add: min_def max_def set_of_def interval_union_def)

lemma interval_union_mono1:
fixes A :: "'a::linorder interval"
shows "set_of a \<subseteq> set_of (interval_union a A)"
by (auto simp add: set_of_def interval_union_def min_def max_def)

lemma interval_union_mono2:
fixes A :: "'a::linorder interval"
shows "set_of A \<subseteq> set_of (interval_union a A)"
by (auto simp add: set_of_def interval_union_def min_def max_def)

lemma interval_exhaust:
obtains l u
where "(i::'a::order interval) = Ivl l u"
and   "l \<le> u"
by (metis Ivl.abs_eq Rep_interval_inverse lower.rep_eq lower_le_upper max_absorb2 prod.swap_def swap_simp swap_swap upper.rep_eq)

(* Definitions that make some common assumptions about lists of intervals easier to write. *)
definition all_in :: "'a::order list \<Rightarrow> 'a interval list \<Rightarrow> bool"
(infix "(all'_in)" 50)
where "x all_in I = (length x = length I \<and> (\<forall>i < length I. x!i \<in> set_of (I!i)))"

definition all_subset :: "'a::order interval list \<Rightarrow> 'a interval list \<Rightarrow> bool"
(infix "(all'_subset)" 50)
where "I all_subset J = (length I = length J \<and> (\<forall>i < length I. set_of (I!i) \<subseteq> set_of (J!i)))"

lemmas [simp] = all_in_def all_subset_def

lemma mid_in_interval:
shows "mid i \<in> set_of i"
proof-
  obtain l u where i_def: "i = Ivl l u" and "l \<le> u" using interval_exhaust by blast

  {
    have "real_of_float l * Float 1 1  \<le> (real_of_float l + real_of_float u)"
      using `l \<le> u` by (simp add: Float.compute_float_one Float.compute_float_times)
    hence "real_of_float l * (Float 1 1 * Float 1 (-1)) \<le> (real_of_float l + real_of_float u) * Float 1 (-1)"
      by simp
    hence "real_of_float l \<le> (real_of_float l + real_of_float u) * Float 1 (- 1)"
      by (simp add: Float.compute_float_one Float.compute_float_times)
  }
  moreover
  {
    have "(real_of_float l + real_of_float u) \<le> real_of_float u * Float 1 1 "
      using `l \<le> u` by (simp add: Float.compute_float_one Float.compute_float_times)
    hence "(real_of_float l + real_of_float u) * Float 1 (-1) \<le> real_of_float u * (Float 1 1 * Float 1 (-1))"
      by simp
    hence "(real_of_float l + real_of_float u) * Float 1 (- 1) \<le> real_of_float u"
      by (simp add: Float.compute_float_one Float.compute_float_times)
  }
  ultimately show ?thesis
    by (simp add: i_def set_of_def mid_def)
qed

lemma all_subsetD:
assumes "I all_subset J"
assumes "x all_in I"
shows "x all_in J"
using assms
by (auto, auto)

instantiation "interval" :: ("{order,equal}") equal
begin
  definition "equal_class.equal a b \<equiv> (lower a = lower b) \<and> (upper a = upper b)"
  instance
  apply(standard)
  apply(simp add: equal_interval_def)
  by (smt interval_exhaust lower_Ivl upper_Ivl_b)
end

(* Arithmetic on intervals. *)
instantiation "interval" :: ("{order,plus}") plus
begin
  definition "a + b = Ivl (lower a + lower b) (upper a + upper b)"
  instance ..
end
instantiation "interval" :: ("{order,minus}") minus
begin
  definition "a - b = Ivl (lower a - upper b) (upper a - lower b)"
  instance ..
end
instantiation "interval" :: ("{order,uminus}") uminus
begin
  definition "-a = Ivl (-upper a) (-lower a)"
  instance ..
end
instantiation "interval" :: ("{times,order}") times
begin
definition "a * b = Ivl (min (min (lower a * lower b) (upper a * lower b))
                             (min (lower a * upper b) (upper a * upper b)))
                        (max (max (lower a * lower b) (upper a * lower b))
                             (max (lower a * upper b) (upper a * upper b)))"
instance ..
end
instantiation "interval" :: ("{order,zero}") zero
begin
  definition "0 = Ivl 0 0"
  instance ..
end
instantiation "interval" :: ("{order,one}") one
begin
  definition "1 = Ivl 1 1"
  instance ..
end
instantiation "interval" :: ("{order,inverse}") inverse
begin
  definition "inverse a = Ivl (min (inverse (lower a)) (inverse (upper a))) (max (inverse (lower a)) (inverse (upper a)))"
  instance ..
end
instantiation "interval" :: ("{order,times,one}") power
begin
  instance ..
end

instantiation "interval" :: (linordered_idom) comm_monoid_add
begin
  instance
  proof
    fix a b c::"'a interval"
    show "a + b + c = a + (b + c)"
      apply(cases a rule: interval_exhaust, cases b rule: interval_exhaust, cases c rule: interval_exhaust)
      by (simp add: plus_interval_def algebra_simps)
  next
    fix a b::"'a interval"
    show "a + b = b + a"
      by (simp add: plus_interval_def algebra_simps)
  next
    fix a::"'a interval"
    show "0 + a = a"
      by (cases a rule: interval_exhaust, simp add: plus_interval_def zero_interval_def)
  qed
end

instantiation "interval" :: (linordered_idom) cancel_semigroup_add
begin
  instance
  proof
    fix a b c::"'a interval"
    assume "a + b = a + c"
    thus "b = c"
      apply(cases a rule: interval_exhaust, cases b rule: interval_exhaust, cases c rule: interval_exhaust)
      apply(simp add: plus_interval_def)
      by (metis add.commute add_mono add_right_imp_eq lower_Ivl upper_Ivl_b)
  next

    fix a b c::"'a interval"
    assume "b + a = c + a"
    thus "b = c"
      apply(cases a rule: interval_exhaust, cases b rule: interval_exhaust, cases c rule: interval_exhaust)
      apply(simp add: plus_interval_def)
      by (metis add_mono_thms_linordered_semiring(1) add_right_cancel lower_Ivl upper_Ivl_b)
  qed
end

fun centered :: "float interval \<Rightarrow> float interval"
where "centered i = i - interval_of (mid i)"

lemma interval_mul_commute:
fixes A :: "'a::linordered_idom interval"
shows "A * B = B * A"
by (simp add: times_interval_def min.commute min.left_commute max.commute max.left_commute mult.commute)

lemma interval_times_zero_right[simp]:
fixes A :: "'a::linordered_idom interval"
shows "A * 0 = 0"
by (simp add: times_interval_def zero_interval_def)

lemma interval_times_zero_left[simp]:
fixes A :: "'a::linordered_idom interval"
shows "0 * A = 0"
by (simp add: times_interval_def zero_interval_def)

lemma one_times_ivl_left[simp]:
fixes A :: "'a::linordered_idom interval"
shows "1 * A = A"
by (cases A rule: interval_exhaust, auto simp: times_interval_def one_interval_def min_def max_def)

lemma one_times_ivl_right[simp]:
fixes A :: "'a::linordered_idom interval"
shows "A * 1 = A"
using one_times_ivl_left[OF assms, unfolded interval_mul_commute]
by assumption

lemma set_of_real_to_float[simp]:
fixes A :: "float interval"
shows "(real_of_float a \<in> set_of (interval_map real_of_float A)) = (a \<in> set_of A)"
by (cases A rule: interval_exhaust, simp add: set_of_def interval_map_def)

(* Coercions on intervals. *)
lemmas [simp] = interval_of_def

declare [[coercion "interval_of :: float \<Rightarrow> float interval"]]
declare [[coercion "interval_of :: real \<Rightarrow> real interval"]]
declare [[coercion_map interval_map]]

(* Coercion of a "float interval" to a "real interval" is homomorph. *)
lemma interval_map_real_add[simp]:
fixes i1::"float interval"
shows "interval_map real_of_float (i1 + i2) = interval_map real_of_float i1 + interval_map real_of_float i2"
by (cases i1 rule: interval_exhaust, cases i2 rule: interval_exhaust, simp add: plus_interval_def interval_map_def)

lemma interval_map_real_sub[simp]:
fixes i1::"float interval"
shows "interval_map real_of_float (i1 - i2) = interval_map real_of_float i1 - interval_map real_of_float i2"
by (cases i1 rule: interval_exhaust, cases i2 rule: interval_exhaust, simp add: minus_interval_def interval_map_def)

lemma interval_map_real_neg[simp]:
fixes i::"float interval"
shows "interval_map real_of_float (-i) = - interval_map real_of_float i"
by (cases i rule: interval_exhaust, simp add: uminus_interval_def interval_map_def)

lemma interval_map_real_mul[simp]:
fixes i1::"float interval"
shows "interval_map real_of_float (i1 * i2) = interval_map real_of_float i1 * interval_map real_of_float i2"
by (cases i1 rule: interval_exhaust, cases i2 rule: interval_exhaust, simp add: times_interval_def real_of_float_max real_of_float_min interval_map_def)

lemma interval_map_real_pow[simp]:
fixes i::"float interval"
shows "interval_map real_of_float (i ^ n) = interval_map real_of_float i ^  n"
apply(cases i rule: interval_exhaust, induction n)
using interval_map_real_mul by (auto simp: one_interval_def interval_map_def)

lemma interval_map_real_Ivl[simp]:
fixes l::float and u::float
shows "interval_map real_of_float (Ivl l u) = Ivl (real_of_float l) (real_of_float u)"
apply(simp add: interval_map_def)
by (metis interval_exhaust less_eq_float.rep_eq lower_Ivl max.cobounded2 max_def upper_Ivl_a upper_Ivl_b)

(* Operations on intervals are monotone. *)
lemma set_of_add_mono:
fixes a :: "'a::ordered_ab_group_add"
assumes "a \<in> set_of A"
assumes "b \<in> set_of B"
shows "a + b \<in> set_of (A + B)"
apply(cases A rule: interval_exhaust, cases B rule: interval_exhaust)
using assms
by (simp add: set_of_def plus_interval_def add_mono)

lemma set_of_minus_mono:
fixes a :: "'a::ordered_ab_group_add"
assumes "a \<in> set_of A"
assumes "b \<in> set_of B"
shows "a - b \<in> set_of (A - B)"
apply(cases A rule: interval_exhaust, cases B rule: interval_exhaust)
using assms
by (simp add: minus_interval_def set_of_def diff_mono)

lemma set_of_uminus_mono:
fixes a :: "'a::ordered_ab_group_add"
assumes "a \<in> set_of A"
shows "-a \<in> set_of (-A)"
apply(cases A rule: interval_exhaust)
using assms
by (simp add: uminus_interval_def set_of_def)

lemma set_of_mult_mono:
fixes a :: "'a::linordered_idom"
assumes "a \<in> set_of A"
assumes "b \<in> set_of B"
shows "a * b \<in> set_of (A * B)"
proof-
  obtain la ua where A_def: "A = Ivl la ua" and lea: "la \<le> ua" using interval_exhaust by auto
  obtain lb ub where B_def: "B = Ivl lb ub" and leb: "lb \<le> ub" using interval_exhaust by auto
  have a_def: "a \<in> {la..ua}" using assms(1) lea by (simp add: A_def set_of_def)
  have b_def: "b \<in> {lb..ub}" using assms(2) leb by (simp add: B_def set_of_def)

  have ineqs: "la \<le> a" "a \<le> ua" "lb \<le> b" "b \<le> ub"
    using a_def b_def
    by auto
  hence ineqs': "-a \<le> -la" "-ua \<le> -a" "-b \<le> -lb" "-ub \<le> -b"
    by(simp_all)

  show ?thesis
    using mult_mono[OF ineqs(1) ineqs(3), simplified]
          mult_mono'[OF ineqs(2) ineqs'(3), simplified]
          mult_mono'[OF ineqs'(1) ineqs(4), simplified]
          mult_mono[OF ineqs'(2) ineqs'(4), simplified]
          mult_mono[OF ineqs'(1) ineqs'(3), simplified]
          mult_mono'[OF ineqs'(2) ineqs(3), simplified]
          mult_mono'[OF ineqs(1) ineqs'(4), simplified]
          mult_mono[OF ineqs(2) ineqs(4), simplified]
          lea leb
    apply(simp add: A_def B_def times_interval_def set_of_def min_le_iff_disj le_max_iff_disj, safe)
    by (smt ineqs(1) ineqs(2) le_less not_le order_trans zero_le_mult_iff)+
qed

lemma set_of_power_mono:
fixes a :: "'a::linordered_idom"
assumes "a \<in> set_of A"
shows "a^n \<in> set_of (A^n)"
using assms
by (induction n, simp_all add: set_of_mult_mono one_interval_def)

(* TODO: Clean this proof up! *)
lemma set_of_add_distrib:
fixes A :: "'a::linordered_idom interval"
shows "set_of A + set_of B = set_of (A + B)"
proof-
  obtain la ua where A_def: "A = Ivl la ua" and lea: "la \<le> ua" using interval_exhaust by auto
  obtain lb ub where B_def: "B = Ivl lb ub" and leb: "lb \<le> ub" using interval_exhaust by auto
  from assms
  show ?thesis
    using lea leb
    apply(simp add: A_def B_def plus_interval_def set_plus_def)
    apply(rule)
    apply(rule)
    apply(safe)
    apply(simp_all add: add_mono set_of_def)
    apply(safe)
    proof(goal_cases)
      case (1 x)
      def wa\<equiv>"ua - la"
      def wb\<equiv>"ub - lb"
      def w\<equiv>"wa + wb"
      def d\<equiv>"x - la - lb"
      have "0 \<le> wa" using 1 by (simp add: wa_def)
      have "0 \<le> wb" using 1 by (simp add: wb_def)
      have "0 \<le> w" using 1 by (simp add: w_def wa_def wb_def)
      hence "0 \<le> d" using 1 by (simp add: d_def)
      have "d \<le> w" using 1 by (simp add: d_def w_def wa_def wb_def)
      hence "d \<le> wa + wb" by (simp add: w_def)

      show ?case
      apply(cases "wa \<le> wb")
      proof-
        case True
        def da\<equiv>"max 0 (min wa (d - wa))"
        def db\<equiv>"d - da"

        have d_decomp: "d = da + db"
          by (simp add: da_def db_def)
        have "x = d + la + lb"
          by (simp add: d_def)
        also have "... =  (la + da) + (lb + db)"
          by (simp add: d_decomp)
        finally have x_decomp: "x = (la + da) + (lb + db)" .
        show "\<exists>a\<in>{la..ua}. \<exists>b\<in>{lb..ub}. x = a + b"
          apply(rule)+
          apply(rule x_decomp)
          apply(simp)
          apply(safe)
          using `0 \<le> d` d_decomp da_def apply linarith
          using True `d \<le> wa + wb` d_decomp da_def wb_def apply linarith
          apply(simp, safe)
          apply (simp add: da_def)
          using "1"(1) da_def wa_def by auto
      next
        case False
        def db\<equiv>"max 0 (min wb (d - wb))"
        def da\<equiv>"d - db"

        have d_decomp: "d = da + db"
          by (simp add: da_def db_def)
        have "x = d + la + lb"
          by (simp add: d_def)
        also have "... =  (la + da) + (lb + db)"
          by (simp add: d_decomp)
        finally have x_decomp: "x = (la + da) + (lb + db)" .

        show "\<exists>a\<in>{la..ua}. \<exists>b\<in>{lb..ub}. x = a + b"
          apply(rule)+
          apply(rule x_decomp)
          apply(simp, safe)
          using db_def apply auto[1]
          using "1"(2) db_def wb_def apply auto[1]
          apply(simp, safe)
          using `0 \<le> d` da_def db_def apply auto[1]
          using False `d \<le> wa + wb` d_decomp db_def wa_def by linarith
      qed
    qed
qed

lemma set_of_add_cong:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A = set_of A'"
assumes "set_of B = set_of B'"
shows "set_of (A + B) = set_of (A' + B')"
by (simp add: set_of_add_distrib[symmetric] assms)

lemma set_of_add_inc_left:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
shows "set_of (A + B) \<subseteq> set_of (A' + B)"
by (simp add: set_of_add_distrib[symmetric] set_plus_mono2[OF assms])

lemma set_of_add_inc_right:
fixes A :: "'a::linordered_idom interval"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A + B) \<subseteq> set_of (A + B')"
using set_of_add_inc_left[OF assms]
by (simp add: add.commute)

lemma set_of_add_inc:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A + B) \<subseteq> set_of (A' + B')"
using set_of_add_inc_left[OF assms(1)] set_of_add_inc_right[OF assms(2)]
by auto

lemma set_of_neg_inc:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
shows "set_of (-A) \<subseteq> set_of (-A')"
apply(cases A rule: interval_exhaust, cases A' rule: interval_exhaust)
using assms by (simp add: uminus_interval_def set_of_def)

lemma set_of_sub_inc_left:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
shows "set_of (A - B) \<subseteq> set_of (A' - B)"
apply(cases A rule: interval_exhaust, cases B rule: interval_exhaust, cases A' rule: interval_exhaust)
using assms by (simp add: uminus_interval_def minus_interval_def plus_interval_def set_of_def)

lemma set_of_sub_inc_right:
fixes A :: "'a::linordered_idom interval"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A - B) \<subseteq> set_of (A - B')"
apply(cases A rule: interval_exhaust, cases B rule: interval_exhaust, cases B' rule: interval_exhaust)
using assms by (simp add: uminus_interval_def minus_interval_def plus_interval_def set_of_def)

lemma set_of_sub_inc:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A - B) \<subseteq> set_of (A' - B')"
using set_of_sub_inc_left[OF assms(1)] set_of_sub_inc_right[OF assms(2)]
by auto

lemma set_of_distrib_right:
fixes A1 :: "'a::linordered_idom interval"
shows "set_of ((A1 + A2) * B) \<subseteq> set_of (A1 * B + A2 * B)"
proof
  fix x assume assm: "x \<in> set_of ((A1 + A2) * B)"

  obtain la1 ua1 where A1_def: "A1 = Ivl la1 ua1" and lea1: "la1 \<le> ua1" using interval_exhaust by auto
  obtain la2 ua2 where A2_def: "A2 = Ivl la2 ua2" and lea2: "la2 \<le> ua2" using interval_exhaust by auto
  obtain lb ub where B_def: "B = Ivl lb ub" and leb: "lb \<le> ub" using interval_exhaust by auto

  from assm
  have a1: "min (min ((la1 + la2) * lb) ((ua1 + ua2) * lb)) (min ((la1 + la2) * ub) ((ua1 + ua2) * ub)) \<le> x"
  and  a2: "x \<le> max (max ((la1 + la2) * lb) ((ua1 + ua2) * lb)) (max ((la1 + la2) * ub) ((ua1 + ua2) * ub))"
    using lea1 lea2 leb
    by (auto simp: A1_def A2_def B_def times_interval_def plus_interval_def set_of_def)

  show "x \<in> set_of (A1 * B + A2 * B)"
    using lea1 lea2 leb
    apply(simp add: A1_def A2_def B_def times_interval_def plus_interval_def set_of_def)
    apply(rule conjI[OF order.trans[OF _ a1]  order.trans[OF a2]])
    apply(smt add_mono distrib_right dual_order.trans min.cobounded1 min_def)
    apply(subst upper_Ivl_b)
    apply(simp add: add_mono max.left_commute min_le_iff_disj)
    apply(smt add_mono distrib_right dual_order.trans max.cobounded2 max_def)
    done
qed

lemma set_of_mul_inc_left:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
shows "set_of (A * B) \<subseteq> set_of (A' * B)"
proof
  fix x assume x_def: "x \<in> set_of (A * B)"

  obtain la ua where A_def: "A = Ivl la ua" and lea: "la \<le> ua" using interval_exhaust by auto
  obtain la' ua' where A'_def: "A' = Ivl la' ua'" and lea': "la' \<le> ua'" using interval_exhaust by auto
  obtain lb ub where B_def: "B = Ivl lb ub" and leb: "lb \<le> ub" using interval_exhaust by auto

  from x_def assms lea lea' leb
  show "x \<in> set_of (A' * B)"
    apply(simp add: A_def A'_def B_def times_interval_def set_of_def)
    apply(safe)
    apply(smt min.absorb_iff2 min.coboundedI2 min_def mult_le_cancel_right)
    by (smt lea lea' leb max_def max_mult_distrib_right min_def min_le_iff_disj mult_compare_simps(1) order_antisym_conv order_trans)
qed

lemma set_of_mul_inc_right:
fixes A :: "'a::linordered_idom interval"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A * B) \<subseteq> set_of (A * B')"
unfolding interval_mul_commute[of A]
by (rule set_of_mul_inc_left[OF assms])

lemma set_of_mul_inc:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
assumes "set_of B \<subseteq> set_of B'"
shows "set_of (A * B) \<subseteq> set_of (A' * B')"
using set_of_mul_inc_right[OF assms(2)] set_of_mul_inc_left[OF assms(1)]
by auto

lemma set_of_pow_inc:
fixes A :: "'a::linordered_idom interval"
assumes "set_of A \<subseteq> set_of A'"
shows "set_of (A^n) \<subseteq> set_of (A'^n)"
using assms
by (induction n, simp_all add: set_of_mul_inc)

lemma set_of_distrib_left:
fixes A1 :: "'a::linordered_idom interval"
shows "set_of (B * (A1 + A2)) \<subseteq> set_of (B * A1 + B * A2)"
unfolding interval_mul_commute
by (rule set_of_distrib_right[unfolded interval_mul_commute])

lemma set_of_distrib_right_left:
fixes A1 :: "'a::linordered_idom interval"
shows "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * B1 + A1 * B2 + A2 * B1 + A2 * B2)"
proof-
  have "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * (B1 + B2) + A2 * (B1 + B2))"
    by (rule set_of_distrib_right)
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + A2 * (B1 + B2))"
    by (rule set_of_add_inc_left[OF set_of_distrib_left])
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + (A2 * B1 + A2 * B2))"
    by (rule set_of_add_inc_right[OF set_of_distrib_left])
  finally show ?thesis
    by (simp add: add.assoc)
qed

lemma set_of_mul_contains_zero:
fixes A :: "'a::linordered_idom interval"
assumes "0 \<in> set_of A \<or> 0 \<in> set_of B"
shows "0 \<in> set_of (A * B)"
using assms
apply(cases A rule: interval_exhaust, cases B rule: interval_exhaust)
apply(simp add: times_interval_def set_of_def)
apply(safe)
apply(metis (no_types, hide_lams) eq_iff min_le_iff_disj mult_zero_left mult_zero_right zero_le_mult_iff)
apply(metis le_max_iff_disj mult_zero_right order_refl zero_le_mult_iff)
apply(metis linear min.coboundedI1 min.coboundedI2 mult_nonneg_nonpos mult_nonpos_nonneg)
apply(metis linear max.coboundedI1 max.coboundedI2 mult_nonneg_nonneg mult_nonpos_nonpos)
done

(* Subdivisions on intervals and interval vectors. *)
fun subdivide_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval list"
where "subdivide_interval 0 I = [I]"
    | "subdivide_interval (Suc n) I = (
         let m = mid I
         in (subdivide_interval n (Ivl (lower I) m)) @ (subdivide_interval n (Ivl m (upper I)))
       )"

fun split_domain :: "(float interval \<Rightarrow> float interval list) \<Rightarrow> float interval list \<Rightarrow> float interval list list"
where "split_domain split [] = [[]]"
    | "split_domain split (I#Is) = (
         let S = split I;
             D = split_domain split Is
         in concat (map (\<lambda>d. map (\<lambda>s. s # d) S) D)
       )"

lemma subdivide_interval_length:
shows "length (subdivide_interval n I) = 2^n"
by(induction n arbitrary: I, simp_all add: Let_def)

lemma subdivide_interval_correct:
fixes x :: real
assumes "x \<in> set_of I"
shows "list_ex (\<lambda>i. x \<in> set_of i) (subdivide_interval n I)"
using assms
apply(induction n arbitrary: x I)
apply(simp_all add: Let_def  list_ex_iff)
(* TODO: better proof. *)
by (metis UnCI atLeastAtMost_iff interval_map_def le_cases lower_Ivl mid_in_interval set_of_def upper_Ivl_b upper_Ivl_upper_lower_real)

lemma split_domain_correct:
fixes x :: "real list"
assumes "x all_in I"
assumes split_correct: "\<And>(x::real) (a::float) I. x \<in> set_of I \<Longrightarrow> list_ex (\<lambda>i::float interval. x \<in> set_of i) (split I)"
shows "list_ex (\<lambda>s. x all_in s) (split_domain split I)"
using assms(1)
proof(induction I arbitrary: x)
  case (Cons I Is x)
  have "x \<noteq> []"
    using Cons(2) by auto
  obtain x' xs where x_decomp: "x = x' # xs"
    using \<open>x \<noteq> []\<close> list.exhaust by auto
  hence "x' \<in> set_of I" "xs all_in Is"
    using Cons(2)
    by auto
  show ?case
    using Cons(1)[OF \<open>xs all_in Is\<close>]
          split_correct[OF \<open>x' \<in> set_of I\<close>]
    apply(simp add: list_ex_iff set_of_def)
    by (smt length_Cons less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc x_decomp)
qed simp

lemma split_domain_nonempty:
assumes "\<And>I. split I \<noteq> []"
shows "split_domain split I \<noteq> []"
using last_in_set assms
by (induction I, auto)

lemma interval_list_union_correct:
assumes "S \<noteq> []"
assumes "i < length S"
shows "set_of (S!i) \<subseteq> set_of (interval_list_union S)"
using assms
proof(induction S arbitrary: i)
  case (Cons a S i)
  thus ?case
    proof(cases S)
      fix b S'
      assume "S = b # S'"
      hence "S \<noteq> []"
        by simp
      show ?thesis
      proof(cases i)
        case 0
        show ?thesis
          apply(cases S)
          using interval_union_mono1
          by (auto simp add: 0)
      next
        case (Suc i_prev)
        hence "i_prev < length S"
        using Cons(3) by simp

        from Cons(1)[OF \<open>S \<noteq> []\<close> this] Cons(1)
        have "set_of ((a # S) ! i) \<subseteq> set_of (interval_list_union S)"
          by (simp add: \<open>i = Suc i_prev\<close>)
        also have "... \<subseteq> set_of (interval_list_union (a # S))"
          using \<open>S \<noteq> []\<close>
          apply(cases S)
          using interval_union_mono2
          by auto
        finally show ?thesis .
      qed
    qed simp
qed simp

(* Rounding of float intervals, by increasing their width. *)
fun round_ivl :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
where "round_ivl prec i = Ivl (float_down prec (lower i)) (float_up prec (upper i))"

lemma float_down_le:
shows "float_down p f \<le> f"
using round_down by simp

lemma float_up_le:
shows "f \<le> float_up p f"
using round_up by simp

lemma round_ivl_correct:
shows "set_of A \<subseteq> set_of (round_ivl prec A)"
proof(cases A rule: interval_exhaust, rule)
  fix l u x
  assume A_decomp: "A = Ivl l u"
  and "l \<le> u"
  and "x \<in> set_of A"
  hence "l \<le> x" and "x \<le> u"
    by (simp_all add: set_of_def)

  have "float_down prec l \<le> x"
    by (rule order.trans[OF float_down_le \<open>l \<le> x\<close>])
  moreover have "x \<le> float_up prec u"
    by (rule order.trans[OF \<open>x \<le> u\<close> float_up_le])
  ultimately show "x \<in> set_of (round_ivl prec A)"
    using \<open>l \<le> u\<close> by (simp add: A_decomp set_of_def)
qed

lemma real_of_float_round_ivl_correct:
shows "set_of A \<subseteq> set_of ((round_ivl prec A) :: real interval)"
proof(rule)
  fix x :: real
  assume "x \<in> set_of A"
  obtain l u where A_decomp: "A = Ivl l u" and "l \<le> u"
    using interval_exhaust by blast
  from \<open>x \<in> set_of A\<close> \<open>l \<le> u\<close>
  have "l \<le> x" "x \<le> u"
    by (auto simp add: set_of_def A_decomp)
  hence "round_down prec l \<le> l"
    and "u \<le> round_up prec u"
    using round_ivl_correct[of A prec] \<open>l \<le> u\<close> round_up
    by (auto simp add: A_decomp set_of_def)
  thus "x \<in> set_of (round_ivl prec A)"
    using \<open>l \<le> x\<close> \<open>x \<le> u\<close>
    by (simp add: set_of_def A_decomp)
qed

end


theory GabrielaLimonta
imports Main
begin

(* Homework 4.1 *)
type_synonym ('q, 'l) lts = "'q \<Rightarrow> 'l \<Rightarrow> 'q \<Rightarrow> bool"

inductive word :: "('q, 'l) lts \<Rightarrow> 'q \<Rightarrow> 'l list \<Rightarrow> 'q \<Rightarrow> bool" for \<delta> where
  E: "word \<delta> u [] u" |
  NE: "\<lbrakk>\<delta> u w x ; word \<delta> x ws v\<rbrakk> \<Longrightarrow> word \<delta> u (w#ws) v"

definition "det \<delta>  \<equiv> \<forall> q a q1 q2. \<delta> q a q1 \<and> \<delta> q a q2 \<longrightarrow> q1 = q2"

inductive_cases empty_elim: "word \<delta> q [] q'"
inductive_simps empty_simp: "word \<delta> q [] q'"

lemma aux[simp]: "word \<delta> q [] q' \<longleftrightarrow> q=q'"
proof
  assume a: "word \<delta> q [] q'"
  thus "q = q'" using empty_elim empty_simp by (metis a)
next
  assume "q=q'"
  thus "word \<delta> q [] q'" using word.E by simp
qed

lemma
  assumes det: "det \<delta>"
  shows "word \<delta> q w q' \<Longrightarrow> word \<delta> q w q'' \<Longrightarrow> q' = q''"
  proof (induction rule: word.induct)
  print_cases
  case E show ?case using E by auto
next
  case (NE u w x ws v)
  show ?case using assms NE aux
  using [[simp_trace]]
sorry
qed

(* Homework 4.2 *)
datatype ab = a | b

inductive_set S :: "ab list set" where
  left: "w1 \<in> S \<Longrightarrow> w2 \<in> S \<Longrightarrow> [a] @ w1 @ [b] @ w2 \<in> S"
| nil: "[] \<in> S"

inductive_set T :: "ab list set" where
  right: "w1 \<in> T \<Longrightarrow> w2 \<in> T \<Longrightarrow> w1 @ [a] @ w2 @ [b] \<in> T"
| nil: "[] \<in> T"

lemma S_SS[simp]:
  assumes "w1 \<in> S"
  assumes "w2 \<in> S"
  shows "w1 @ w2 \<in> S"
using assms
proof (induction rule: S.induct)
print_cases
  case nil show ?case using nil.prems S.left S.nil by simp
next
  case (left w1 w2)
  show ?case using S.left left append_assoc append_Cons append_Nil by auto
qed

lemma T_TT[simp]:
  assumes "w1 \<in> T"
  assumes "w2 \<in> T"
  shows "w2 @ w1 \<in> T"
using assms
proof (induction rule: T.induct)
print_cases
  case nil show ?case using nil.prems T.right T.nil by simp
next
  case (right w1 w2)
  show ?case using right append_assoc append_Cons append_Nil by (metis T.right)
qed

lemma S_imp_T:
  assumes w: "w \<in> S"
  shows "w \<in> T"
  using assms
proof (induction rule: S.induct)
print_cases
  case nil show ?case using T.nil by simp
next
  case (left w1 w2)
  show ?case
  using left T.intros append_assoc append_Cons append_Nil T_TT
  by (metis Tp_T_eq)
qed

lemma T_imp_S:
  assumes w: "w \<in> T"
  shows "w \<in> S"
using assms
proof (induction rule: T.induct)
print_cases
  case nil show ?case using S.nil by simp
next
  case (right w1 w2)
  show ?case
  using right S.intros append_assoc append_Cons append_Nil S_SS by simp
qed

lemma "S = T"
proof
  show "S \<subseteq> T"
  using S_imp_T by auto
next
  show "T \<subseteq> S"
  using T_imp_S by auto
qed

end