(*
Authors:

  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk;
  Yijun He, University of Cambridge, yh403@cam.ac.uk
*)

theory Quantum_Teleportation
imports
  More_Tensor
  Basics
  Measurement
begin

definition alice:: "complex Matrix.mat \<Rightarrow> complex Matrix.mat" where
"alice \<phi> \<equiv> (H \<Otimes> Id 2) * ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>))"

abbreviation M1:: "complex Matrix.mat" where
"M1 \<equiv> mat_of_cols_list 8 [[1, 0, 0, 0, 0, 0, 0, 0],
                          [0, 1, 0, 0, 0, 0, 0, 0],
                          [0, 0, 1, 0, 0, 0, 0, 0],
                          [0, 0, 0, 1, 0, 0, 0, 0],
                          [0, 0, 0, 0, 0, 0, 1, 0],
                          [0, 0, 0, 0, 0, 0, 0, 1],
                          [0, 0, 0, 0, 1, 0, 0, 0],
                          [0, 0, 0, 0, 0, 1, 0, 0]]"

lemma tensor_prod_of_cnot_id_1:
  shows "(CNOT \<Otimes> Id 1) = M1"
proof
  show "dim_col (CNOT \<Otimes> Id 1) = dim_col M1"
    by(simp add: CNOT_def Id_def mat_of_cols_list_def)
  show "dim_row (CNOT \<Otimes> Id 1) = dim_row M1"
    by(simp add: CNOT_def Id_def  mat_of_cols_list_def)
  fix i j::nat assume "i < dim_row M1" and "j < dim_col M1"
  then have "i \<in> {0..<8} \<and> j \<in> {0..<8}"
    by (auto simp add:  mat_of_cols_list_def)
  then show "(CNOT \<Otimes> Id 1) $$ (i, j) = M1 $$ (i, j)"
    by (auto simp add: Id_def CNOT_def mat_of_cols_list_def)
qed

abbreviation M2:: "complex Matrix.mat" where
"M2 \<equiv> mat_of_cols_list 8 [[1/sqrt(2), 0, 0, 0, 1/sqrt(2), 0, 0, 0],
                          [0, 1/sqrt(2), 0, 0, 0, 1/sqrt(2), 0, 0],
                          [0, 0, 1/sqrt(2), 0, 0, 0, 1/sqrt(2), 0],
                          [0, 0, 0, 1/sqrt(2), 0, 0, 0, 1/sqrt(2)],
                          [1/sqrt(2), 0, 0, 0, -1/sqrt(2), 0, 0, 0],
                          [0, 1/sqrt(2), 0, 0, 0, -1/sqrt(2), 0, 0],
                          [0, 0, 1/sqrt(2), 0, 0, 0, -1/sqrt(2), 0],
                          [0, 0, 0, 1/sqrt(2), 0, 0, 0, -1/sqrt(2)]]"

lemma tensor_prod_of_h_id_2:
  shows "(H \<Otimes> Id 2) = M2"
proof
  show "dim_col (H \<Otimes> Id 2) = dim_col M2"
    by(simp add: H_def Id_def mat_of_cols_list_def)
  show "dim_row (H \<Otimes> Id 2) = dim_row M2"
    by(simp add: H_def Id_def mat_of_cols_list_def)
  fix i j::nat assume "i < dim_row M2" and "j < dim_col M2"
  then have "i \<in> {0..<8} \<and> j \<in> {0..<8}"
    by (auto simp add:  mat_of_cols_list_def)
  then show "(H \<Otimes> Id 2) $$ (i, j) = M2 $$ (i, j)"
    by (auto simp add: Id_def H_def mat_of_cols_list_def)
qed

lemma alice_step_1_state [simp]:
  assumes "state 1 \<phi>"
  shows "state 3 (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)"
  using assms bell00_is_state tensor_state by(metis One_nat_def Suc_1 numeral_3_eq_3 plus_1_eq_Suc)

lemma alice_step_2_state:
  assumes "state 1 \<phi>"
  shows "state 3 ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>))"
proof-
  have "gate 3 (CNOT \<Otimes> Id 1)"
    using CNOT_is_gate id_is_gate tensor_gate by (metis numeral_plus_one semiring_norm(5))
  then show "state 3 ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>))" using assms by simp
qed

lemma alice_state [simp]:
  assumes "state 1 \<phi>"
  shows "state 3 (alice \<phi>) "
proof-
  have "gate 3 (H \<Otimes> Id 2)"
    using tensor_gate id_is_gate H_is_gate by(metis eval_nat_numeral(3) plus_1_eq_Suc)
  then show ?thesis
    using assms alice_step_2_state by(simp add: alice_def)
qed

lemma alice_step_1:
  assumes "state 1 \<phi>" and "\<alpha> = \<phi> $$ (0,0)" and "\<beta> = \<phi> $$ (1,0)"
  shows "(\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) = mat_of_cols_list 8 [[\<alpha>/sqrt(2),0,0,\<alpha>/sqrt(2),\<beta>/sqrt(2),0,0,\<beta>/sqrt(2)]]"
proof
  define v where asm:"v = mat_of_cols_list 8 [[\<alpha>/sqrt(2),0,0,\<alpha>/sqrt(2),\<beta>/sqrt(2),0,0,\<beta>/sqrt(2)]]"
  then show "dim_row (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) = dim_row v"
    using assms(1) alice_step_1_state state.dim_row mat_of_cols_list_def by fastforce
  show "dim_col (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) = dim_col v"
    using assms(1) alice_step_1_state state.is_column asm mat_of_cols_list_def by fastforce
  show "\<And>i j. i < dim_row v \<Longrightarrow> j < dim_col v \<Longrightarrow> (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) $$ (i,j) = v $$ (i,j)"
  proof-
    fix i j assume "i < dim_row v" and "j < dim_col v"
    then have "i \<in> {0..<8} \<and> j = 0"
      using asm by (auto simp add: mat_of_cols_list_def)
    moreover have "dim_row |\<beta>\<^sub>0\<^sub>0\<rangle> = 4"
      using bell00_is_state state_def by simp
    moreover have "dim_col |\<beta>\<^sub>0\<^sub>0\<rangle> = 1"
      using bell00_is_state state_def by simp
    ultimately show "(\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) $$ (i, j) = v $$ (i,j)"
      using state_def assms asm by (auto simp add: bell00_def)
  qed
qed

lemma alice_step_2:
  assumes "state 1 \<phi>" and "\<alpha> = \<phi> $$ (0,0)" and "\<beta> = \<phi> $$ (1,0)"
  shows "(CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) = mat_of_cols_list 8 [[\<alpha>/sqrt(2),0,0,\<alpha>/sqrt(2),0,\<beta>/sqrt(2),\<beta>/sqrt(2),0]]"
proof
  have f0:"(\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>) = mat_of_cols_list 8 [[\<alpha>/sqrt(2),0,0,\<alpha>/sqrt(2),\<beta>/sqrt(2),0,0,\<beta>/sqrt(2)]]"
    using assms alice_step_1 by simp
  define v where asm:"v = mat_of_cols_list 8 [[\<alpha>/sqrt(2),0,0,\<alpha>/sqrt(2),0,\<beta>/sqrt(2),\<beta>/sqrt(2),0]]"
  then show "dim_row ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)) = dim_row v"
    using assms(1) alice_step_2_state state.dim_row mat_of_cols_list_def by fastforce
  show "dim_col ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)) = dim_col v"
    using assms(1) alice_step_2_state state.is_column asm mat_of_cols_list_def by fastforce
  show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> ((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)) $$ (i,j) = v $$ (i,j)"
  proof-
    fix i j assume "i < dim_row v" and "j < dim_col v"
    then have "i \<in> {0..<8::nat} \<and> j = 0"
      using asm by (auto simp add: mat_of_cols_list_def)
    then have "(M1 * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)) $$ (i,j) = v $$ (i,j)"
      by (auto simp add: f0 asm mat_of_cols_list_def times_mat_def scalar_prod_def)
    then show "((CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)) $$ (i,j) = v $$ (i,j)"
      using tensor_prod_of_cnot_id_1 by simp
  qed
qed

lemma alice_result:
  assumes "state 1 \<phi>" and "\<alpha> = \<phi> $$ (0,0)" and "\<beta> = \<phi> $$ (1,0)"
  shows "alice \<phi> = mat_of_cols_list 8 [[\<alpha>/2, \<beta>/2, \<beta>/2, \<alpha>/2, \<alpha>/2, -\<beta>/2, -\<beta>/2, \<alpha>/2]]"
proof
  define v where a0:"v = mat_of_cols_list 8 [[\<alpha>/2, \<beta>/2, \<beta>/2, \<alpha>/2, \<alpha>/2, -\<beta>/2, -\<beta>/2, \<alpha>/2]]"
  define w where a1:"w = (CNOT \<Otimes> Id 1) * (\<phi> \<Otimes> |\<beta>\<^sub>0\<^sub>0\<rangle>)"
  then have f0:"w = mat_of_cols_list 8 [[\<alpha>/sqrt(2), 0, 0, \<alpha>/sqrt(2), 0, \<beta>/sqrt(2), \<beta>/sqrt(2), 0]]"
    using assms alice_step_2 by simp
  show "dim_row (alice \<phi>) = dim_row v"
    using assms(1) alice_state state_def a0 by (simp add: mat_of_cols_list_def)
  show "dim_col (alice \<phi>) = dim_col v"
    using assms(1) alice_state state_def a0 by (simp add: mat_of_cols_list_def)
  show "\<And>i j. i < dim_row v \<Longrightarrow> j < dim_col v \<Longrightarrow> alice \<phi> $$ (i,j) = v $$ (i,j)"
  proof-
    fix i j assume "i < dim_row v" and "j < dim_col v"
    then have "i \<in> {0..<8} \<and> j = 0"
      using a0 by (auto simp add: Tensor.mat_of_cols_list_def)
    then have "(M2 * w) $$ (i,j) = v $$ (i,j)"
      by (auto simp add: f0 a0 mat_of_cols_list_def times_mat_def scalar_prod_def)
    then show "alice \<phi> $$ (i,j) = v $$ (i,j)"
      by (simp add: tensor_prod_of_h_id_2 alice_def a1)
  qed
qed

text \<open>
An application of function @{term alice} to a state \<phi> of a 1-qubit system results in the following cases.
\<close>

definition alice_meas:: "complex Matrix.mat \<Rightarrow> _list" where
"alice_meas \<phi> = [
  ((prob0 3 (alice \<phi>) 0) * (prob0 3 (post_meas0 3 (alice \<phi>) 0) 1), post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1)
, ((prob0 3 (alice \<phi>) 0) * (prob1 3 (post_meas0 3 (alice \<phi>) 0) 1), post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1)
, ((prob1 3 (alice \<phi>) 0) * (prob0 3 (post_meas1 3 (alice \<phi>) 0) 1), post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1)
, ((prob1 3 (alice \<phi>) 0) * (prob1 3 (post_meas1 3 (alice \<phi>) 0) 1), post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1)
]"

definition alice_pos:: "complex Matrix.mat \<Rightarrow> complex Matrix.mat \<Rightarrow> bool" where
"alice_pos \<phi> q \<equiv>  q = mat_of_cols_list 8 [[\<phi> $$ (0,0), \<phi> $$ (1,0), 0, 0, 0, 0, 0, 0]] \<or>
                  q = mat_of_cols_list 8 [[0, 0, \<phi> $$ (1,0), \<phi> $$ (0,0), 0, 0, 0, 0]] \<or>
                  q = mat_of_cols_list 8 [[0, 0, 0, 0, \<phi> $$ (0,0), - \<phi> $$ (1,0), 0, 0]] \<or>
                  q = mat_of_cols_list 8 [[0, 0, 0, 0, 0, 0, - \<phi> $$ (1,0), \<phi> $$ (0,0)]]"

lemma phi_vec_length:
  assumes "state 1 \<phi>"
  shows "cmod(\<phi> $$ (0,0))^2 + cmod(\<phi> $$ (Suc 0,0))^2 = 1"
  using set_2 assms state_def Matrix.col_def cpx_vec_length_def by(auto simp add: atLeast0LessThan)

lemma select_index_3_subsets [simp]:
  shows "{j::nat. select_index 3 0 j} = {4,5,6,7} \<and>
         {j::nat. j < 8 \<and> \<not> select_index 3 0 j} = {0,1,2,3} \<and>
         {j::nat. select_index 3 1 j} = {2,3,6,7} \<and>
         {j::nat. j < 8 \<and> \<not> select_index 3 1 j} = {0,1,4,5}"
proof-
  have "{j::nat. select_index 3 0 j} = {4,5,6,7}" by (auto simp add: select_index_def)
  moreover have "{j::nat. j < 8 \<and> \<not> select_index 3 0 j} = {0,1,2,3}" by(auto simp add: select_index_def)
  moreover have f1:"{j::nat. select_index 3 1 j} = {2,3,6,7}"
  proof
    show "{j. select_index 3 1 j} \<subseteq> {2,3,6,7}"
    proof
      fix j::nat assume "j \<in> {j. select_index 3 1 j}"
      then have "j \<in> {0..<8} \<and> j mod 4 \<in> {2,3}" by (auto simp add: select_index_def)
      then show "j \<in> {2,3,6,7}" by auto
    qed
    show "{2,3,6,7} \<subseteq> {j. select_index 3 1 j}" by (auto simp add: select_index_def)
  qed
  moreover have "{j::nat. j < 8 \<and> \<not> select_index 3 1 j} = {0,1,4,5}"
  proof-
    have "{j::nat. j < 8 \<and> j \<notin> {2,3,6,7}} = {0,1,4,5}"  by auto
    then show ?thesis using f1 by blast
  qed
  ultimately show ?thesis by simp
qed

lemma prob_index_0_alice:
  assumes "state 1 \<phi>"
  shows "prob0 3 (alice \<phi>) 0 = 1/2 \<and> prob1 3 (alice \<phi>) 0 = 1/2"
proof
  show "prob0 3 (alice \<phi>) 0 = 1/2"
    using alice_result assms prob0_def alice_state
    apply auto by (metis (no_types, hide_lams) One_nat_def phi_vec_length four_x_squared mult.commute
nonzero_mult_div_cancel_right times_divide_eq_right zero_neq_numeral)
  then show"prob1 3 (alice \<phi>) 0 = 1/2"
    using prob_sum_is_one[of "3" "alice \<phi>" "0"] alice_state[of "\<phi>"] assms by linarith
qed

lemma post_meas0_index_0_alice:
  assumes "state 1 \<phi>" and "\<alpha> = \<phi> $$ (0,0)" and "\<beta> = \<phi> $$ (1,0)"
  shows "post_meas0 3 (alice \<phi>) 0 =
mat_of_cols_list 8 [[\<alpha>/sqrt(2), \<beta>/sqrt(2), \<beta>/sqrt(2), \<alpha>/sqrt(2), 0, 0, 0, 0]]"
proof
  define v where asm:"v = mat_of_cols_list 8 [[\<alpha>/sqrt(2),\<beta>/sqrt(2),\<beta>/sqrt(2),\<alpha>/sqrt(2),0,0,0,0]]"
  then show "dim_row (post_meas0 3 (alice \<phi>) 0) = dim_row v"
    using mat_of_cols_list_def post_meas0_def assms(1) alice_state ket_vec_def by simp
  show "dim_col (post_meas0 3 (alice \<phi>) 0) = dim_col v"
    using mat_of_cols_list_def post_meas0_def assms(1) alice_state ket_vec_def asm by simp
  show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas0 3 (alice \<phi>) 0 $$ (i,j) = v $$ (i,j)"
  proof-
    fix i j assume "i < dim_row v" and "j < dim_col v"
    then have "i \<in> {0..<8} \<and> j = 0"
      using asm set_8_atLeast0 mat_of_cols_list_def by auto
    then show "post_meas0 3 (alice \<phi>) 0 $$ (i, j) = v $$ (i, j)"
      using post_meas0_def assms asm mat_of_cols_list_def ket_vec_def
      apply (auto simp add: prob_index_0_alice)
      using assms(1) alice_result select_index_def by auto
  qed
qed

lemma post_meas1_index_0_alice:
  assumes "state 1 \<phi>" and "\<alpha> = \<phi> $$ (0,0)" and "\<beta> = \<phi> $$ (1,0)"
  shows "post_meas1 3 (alice \<phi>) 0 = mat_of_cols_list 8 [[0,0,0,0,\<alpha>/sqrt(2),-\<beta>/sqrt(2),-\<beta>/sqrt(2),\<alpha>/sqrt(2)]]"
proof
  define v where asm:"v = mat_of_cols_list 8 [[0,0,0,0,\<alpha>/sqrt(2),-\<beta>/sqrt(2),-\<beta>/sqrt(2),\<alpha>/sqrt(2)]]"
  then show "dim_row (post_meas1 3 (alice \<phi>) 0) = dim_row v"
    using mat_of_cols_list_def post_meas1_def assms(1) alice_state ket_vec_def by simp
  show "dim_col (post_meas1 3 (alice \<phi>) 0) = dim_col v"
    using mat_of_cols_list_def post_meas1_def assms(1) alice_state ket_vec_def asm by simp
  show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas1 3 (alice \<phi>) 0 $$ (i,j) = v $$ (i,j)"
  proof-
    fix i j assume "i < dim_row v" and "j < dim_col v"
    then have "i \<in> {0..<8} \<and> j = 0"
      using asm set_8_atLeast0 mat_of_cols_list_def by auto
    then show "post_meas1 3 (alice \<phi>) 0 $$ (i,j) = v $$ (i,j)"
      using post_meas1_def assms asm mat_of_cols_list_def ket_vec_def
      apply (auto simp add: prob_index_0_alice)
      using assms(1) alice_result select_index_def by auto
  qed
qed

lemma post_meas0_index_0_alice_state [simp]:
  assumes "state 1 \<phi>"
  shows "state 3 (post_meas0 3 (alice \<phi>) 0)"
  using assms by (simp add: prob_index_0_alice)

lemma post_meas1_index_0_alice_state [simp]:
  assumes "state 1 \<phi>"
  shows "state 3 (post_meas1 3 (alice \<phi>) 0)"
  using assms by (simp add: prob_index_0_alice)

lemma Alice_case [simp]:
  assumes "state 1 \<phi>" and "state 3 q" and "List.member (alice_meas \<phi>) (p, q)"
  shows "alice_pos \<phi> q"
proof-
  define \<alpha> \<beta> where a0:"\<alpha> = \<phi> $$ (0,0)" and a1:"\<beta> = \<phi> $$ (1,0)"
  have f0:"prob0 3 (Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[\<phi> $$ (0,0)/sqrt 2, \<phi> $$ (Suc 0,0)/sqrt 2,
                    \<phi> $$ (Suc 0,0)/sqrt 2, \<phi> $$ (0,0)/sqrt 2,0,0,0,0]]!j!i)) (Suc 0) = 1/2"
    using post_meas0_index_0_alice prob0_def mat_of_cols_list_def post_meas0_index_0_alice_state
assms(1) a0 a1 select_index_3_subsets by (auto simp add: norm_divide power_divide phi_vec_length)
  have f1:"prob1 3 (Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[\<phi> $$ (0,0)/sqrt 2, \<phi> $$ (Suc 0,0)/sqrt 2,
                    \<phi> $$ (Suc 0,0)/sqrt 2, \<phi> $$ (0,0)/sqrt 2, 0, 0, 0, 0]] ! j ! i)) (Suc 0) = 1/2"
    using post_meas0_index_0_alice prob1_def mat_of_cols_list_def post_meas0_index_0_alice_state
assms(1) a0 a1 select_index_3_subsets by(auto simp add: norm_divide power_divide phi_vec_length algebra_simps)
  have f2:"prob0 3 (Matrix.mat 8 (Suc 0)
          (\<lambda>(i,j). [[0,0,0,0,\<phi> $$ (0,0)/complex_of_real (sqrt 2),-(\<phi> $$ (Suc 0,0)/complex_of_real (sqrt 2)),
-(\<phi> $$ (Suc 0,0)/complex_of_real (sqrt 2)),\<phi> $$ (0,0)/complex_of_real (sqrt 2)]] ! j ! i)) (Suc 0) = 1/2"
    using post_meas1_index_0_alice prob0_def mat_of_cols_list_def post_meas1_index_0_alice_state
      assms(1) a0 a1 select_index_3_subsets by(auto simp add: norm_divide power_divide phi_vec_length)
  have f3:"prob1 3 (Matrix.mat 8 (Suc 0)
          (\<lambda>(i,j). [[0,0,0,0,\<phi> $$ (0,0)/complex_of_real (sqrt 2),-(\<phi> $$ (Suc 0,0)/complex_of_real (sqrt 2)),
-(\<phi> $$ (Suc 0,0)/complex_of_real (sqrt 2)), \<phi> $$ (0,0)/complex_of_real (sqrt 2)]] ! j ! i)) (Suc 0) = 1/2"
    using post_meas1_index_0_alice prob1_def mat_of_cols_list_def post_meas1_index_0_alice_state
assms(1) a0 a1 select_index_3_subsets by(auto simp add: norm_divide power_divide phi_vec_length algebra_simps)
  have "(p, q) = ((prob0 3 (alice \<phi>) 0) * (prob0 3 (post_meas0 3 (alice \<phi>) 0) 1), post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1) \<or>
        (p, q) = ((prob0 3 (alice \<phi>) 0) * (prob1 3 (post_meas0 3 (alice \<phi>) 0) 1), post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1) \<or>
        (p, q) = ((prob1 3 (alice \<phi>) 0) * (prob0 3 (post_meas1 3 (alice \<phi>) 0) 1), post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1) \<or>
        (p, q) = ((prob1 3 (alice \<phi>) 0) * (prob1 3 (post_meas1 3 (alice \<phi>) 0) 1), post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1)"
    using assms(3) alice_meas_def List.member_def by(smt list.distinct(1) list.exhaust list.inject member_rec(1) member_rec(2))
  then have "q = post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1 \<or> q = post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1 \<or>
             q = post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1 \<or> q = post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1"
    by auto
  moreover have "post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1 = mat_of_cols_list 8 [[\<alpha>,\<beta>,0,0,0,0,0,0]]"
  proof
    define v where asm:"v = mat_of_cols_list 8 [[\<alpha>, \<beta>, 0, 0, 0, 0, 0, 0]]"
    then show "dim_row (post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1) = dim_row v"
      using mat_of_cols_list_def post_meas0_def ket_vec_def by simp
    show "dim_col (post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1) = dim_col v"
      using mat_of_cols_list_def post_meas0_def ket_vec_def asm by simp
    show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
    proof-
      fix i j assume "i < dim_row v" and "j < dim_col v"
      then have "i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def by auto
      then show "post_meas0 3 (post_meas0 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
        using post_meas0_index_0_alice assms(1) a0 a1
        apply (auto)
        using post_meas0_def asm mat_of_cols_list_def ket_vec_def select_index_def
        by (auto simp add: f0 real_sqrt_divide)
    qed
  qed
  moreover have "post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1 = mat_of_cols_list 8 [[0,0,\<beta>,\<alpha>,0,0,0,0]]"
  proof
    define v where asm:"v = mat_of_cols_list 8 [[0,0,\<beta>,\<alpha>,0,0,0,0]]"
    then show "dim_row (post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1) = dim_row v"
      using mat_of_cols_list_def post_meas1_def ket_vec_def asm by auto
    show "dim_col (post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1) = dim_col v"
      using mat_of_cols_list_def post_meas1_def ket_vec_def asm by auto
    show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
    proof-
      fix i j assume "i < dim_row v" and "j < dim_col v"
      then have "i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def by auto
      then show "post_meas1 3 (post_meas0 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
        using post_meas0_index_0_alice assms(1) a0 a1
        apply (auto)
        using post_meas1_def asm mat_of_cols_list_def ket_vec_def select_index_def
        by (auto simp add: f1 real_sqrt_divide)
    qed
  qed
  moreover have "post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1 = mat_of_cols_list 8 [[0,0,0,0,\<alpha>,-\<beta>,0,0]]"
  proof
    define v where asm:"v = mat_of_cols_list 8 [[0, 0, 0, 0, \<alpha>, -\<beta>, 0, 0]]"
    then show "dim_row (post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1) = dim_row v"
      using mat_of_cols_list_def post_meas0_def ket_vec_def by simp
    show "dim_col (post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1) = dim_col v"
      using mat_of_cols_list_def post_meas0_def ket_vec_def asm by simp
    show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
    proof-
      fix i j assume "i < dim_row v" and "j < dim_col v"
      then have "i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def by auto
      then show "post_meas0 3 (post_meas1 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
        using post_meas1_index_0_alice assms(1) a0 a1
        apply (auto)
        using post_meas0_def asm mat_of_cols_list_def ket_vec_def select_index_def
        by (auto simp add: f2 real_sqrt_divide)
    qed
  qed
  moreover have "post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1 = mat_of_cols_list 8 [[0,0,0,0,0,0,-\<beta>,\<alpha>]]"
  proof
    define v where asm:"v = mat_of_cols_list 8 [[0,0,0,0,0,0,-\<beta>,\<alpha>]]"
    then show "dim_row (post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1) = dim_row v"
      using mat_of_cols_list_def post_meas1_def ket_vec_def by simp
    show "dim_col (post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1) = dim_col v"
      using mat_of_cols_list_def post_meas1_def ket_vec_def asm by simp
    show "\<And>i j. i<dim_row v \<Longrightarrow> j<dim_col v \<Longrightarrow> post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
    proof-
      fix i j assume "i < dim_row v" and "j < dim_col v"
      then have "i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def by auto
      then show "post_meas1 3 (post_meas1 3 (alice \<phi>) 0) 1 $$ (i,j) = v $$ (i,j)"
        using post_meas1_index_0_alice assms(1) a0 a1
        apply (auto)
        using post_meas1_def asm mat_of_cols_list_def ket_vec_def select_index_def
        by (auto simp add: f3 real_sqrt_divide)
    qed
  qed
  ultimately show ?thesis using alice_pos_def a0 a1 by simp
qed

datatype bit = zero | one

definition alice_out:: "complex Matrix.mat => complex Matrix.mat => bit \<times> bit" where
"alice_out \<phi> q \<equiv>
if q = mat_of_cols_list 8 [[\<phi> $$ (0,0), \<phi> $$ (1,0), 0, 0, 0, 0, 0, 0]] then (zero, zero) else
  if q = mat_of_cols_list 8 [[0, 0, \<phi> $$ (1,0), \<phi> $$ (0,0), 0, 0, 0, 0]] then (zero, one) else
    if q = mat_of_cols_list 8 [[0, 0, 0, 0, \<phi> $$ (0,0), - \<phi> $$ (1,0), 0, 0]] then (one, zero) else
      if q = mat_of_cols_list 8 [[0, 0, 0, 0, 0, 0, - \<phi> $$ (1,0), \<phi> $$ (0,0)]] then (one, one) else
        undefined"

definition bob:: "complex Matrix.mat => bit \<times> bit \<Rightarrow> complex Matrix.mat" where
"bob q b \<equiv>
if (fst b, snd b) = (zero, zero) then q else
  if (fst b, snd b) = (zero, one) then (Id 2 \<Otimes> X) * q else
    if (fst b, snd b) = (one, zero) then (Id 2 \<Otimes> Z) * q else
      if (fst b, snd b) = (one, one) then (Id 2 \<Otimes> Z * X) * q else
        undefined"

lemma alice_out_unique [simp]:
  assumes "state 1 \<phi>"
  shows "Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, \<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0), 0, 0, 0, 0]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[\<phi> $$ (0, 0), \<phi> $$ (Suc 0, 0), 0, 0, 0, 0, 0, 0]]!j!i) \<and>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, \<phi> $$ (0, 0), -\<phi> $$ (Suc 0, 0), 0, 0]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[\<phi> $$ (0, 0), \<phi> $$ (Suc 0, 0), 0, 0, 0, 0, 0, 0]]!j!i) \<and>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, 0, 0, -\<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0)]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[\<phi> $$ (0, 0), \<phi> $$ (Suc 0, 0), 0, 0, 0, 0, 0, 0]]!j!i) \<and>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, \<phi> $$ (0, 0), -\<phi> $$ (Suc 0, 0), 0, 0]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, \<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0), 0, 0, 0, 0]]!j!i) \<and>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, 0, 0, -\<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0)]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, \<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0), 0, 0, 0, 0]]!j!i) \<and>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, 0, 0, -\<phi> $$ (Suc 0, 0), \<phi> $$ (0, 0)]]!j!i) \<noteq>
         Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0, 0, 0, 0, \<phi> $$ (0, 0), -\<phi> $$ (Suc 0, 0), 0, 0]]!j!i)"
proof-
  have f0:"\<phi> $$ (0,0) \<noteq> 0 \<or> \<phi> $$ (1,0) \<noteq> 0"
    using assms state_def Matrix.col_def cpx_vec_length_def set_2 by(auto simp add: atLeast0LessThan)
  define v1 v2 v3 v4 where d0:"v1 = Matrix.mat 8 1 (\<lambda>(i,j). [[\<phi> $$ (0,0),\<phi> $$ (1,0),0,0,0,0,0,0]]!j!i)"
                       and d1:"v2 = Matrix.mat 8 1 (\<lambda>(i,j). [[0,0,\<phi> $$ (1,0), \<phi> $$ (0,0),0,0,0,0]]!j!i)"
                       and d2:"v3 = Matrix.mat 8 1 (\<lambda>(i,j). [[0,0,0,0,\<phi> $$ (0,0),-\<phi> $$ (1,0),0,0]]!j!i)"
                       and d3:"v4 = Matrix.mat 8 1 (\<lambda>(i,j). [[0,0,0,0,0,0,-\<phi> $$ (1,0),\<phi> $$ (0,0)]]!j!i)"
  then have "(v1 $$ (0,0) \<noteq> v2 $$ (0,0) \<or> v1 $$ (1,0) \<noteq> v2 $$ (1,0)) \<and>
             (v1 $$ (0,0) \<noteq> v3 $$ (0,0) \<or> v1 $$ (1,0) \<noteq> v3 $$ (1,0)) \<and>
             (v1 $$ (0,0) \<noteq> v4 $$ (0,0) \<or> v1 $$ (1,0) \<noteq> v4 $$ (1,0)) \<and>
             (v2 $$ (2,0) \<noteq> v3 $$ (2,0) \<or> v2 $$ (3,0) \<noteq> v3 $$ (3,0)) \<and>
             (v2 $$ (2,0) \<noteq> v4 $$ (2,0) \<or> v2 $$ (3,0) \<noteq> v4 $$ (3,0)) \<and>
             (v3 $$ (4,0) \<noteq> v4 $$ (4,0) \<or> v3 $$ (5,0) \<noteq> v4 $$ (5,0))" using f0 by auto
  then have "v1 \<noteq> v2 \<and> v1 \<noteq> v3 \<and> v1 \<noteq> v4 \<and> v2 \<noteq> v3 \<and> v2 \<noteq> v4 \<and> v3 \<noteq> v4" by auto
  thus ?thesis by (auto simp add: d0 d1 d2 d3)
qed

abbreviation M3:: "complex Matrix.mat" where
"M3 \<equiv> mat_of_cols_list 8 [[0, 1, 0, 0, 0, 0, 0, 0],
                          [1, 0, 0, 0, 0, 0, 0, 0],
                          [0, 0, 0, 1, 0, 0, 0, 0],
                          [0, 0, 1, 0, 0, 0, 0, 0],
                          [0, 0, 0, 0, 0, 1, 0, 0],
                          [0, 0, 0, 0, 1, 0, 0, 0],
                          [0, 0, 0, 0, 0, 0, 0, 1],
                          [0, 0, 0, 0, 0, 0, 1, 0]]"

lemma tensor_prod_of_id_2_x:
  shows "(Id 2 \<Otimes> X) = M3"
proof
    have f0:"gate 3 (Id 2 \<Otimes> X)"
      using X_is_gate tensor_gate[of "2" "Id 2" "1" "X"] by simp
    then show "dim_row (Id 2 \<Otimes> X) = dim_row M3"
      using gate_def by (simp add: mat_of_cols_list_def)
    show "dim_col (Id 2 \<Otimes> X) = dim_col M3"
      using f0 gate_def by (simp add: mat_of_cols_list_def)
    show "\<And>i j. i < dim_row M3 \<Longrightarrow> j < dim_col M3 \<Longrightarrow> (Id 2 \<Otimes> X) $$ (i,j) = M3 $$ (i,j)"
    proof-
      fix i j assume "i < dim_row M3" and "j < dim_col M3"
      then have "i \<in> {0..<8} \<and> j \<in> {0..<8}" by (auto simp add: mat_of_cols_list_def)
      then show "(Id 2 \<Otimes> X) $$ (i,j) = M3 $$ (i,j)"
        using Id_def X_def index_tensor_mat[of "Id 2" "4" "4" "X" "2" "2" "i" "j"] gate_def X_is_gate
id_is_gate Id_def by (auto simp add: mat_of_cols_list_def X_def)
    qed
qed

abbreviation M4:: "complex Matrix.mat" where
"M4 \<equiv> mat_of_cols_list 8 [[0, -1, 0, 0, 0, 0, 0, 0],
                          [1, 0, 0, 0, 0, 0, 0, 0],
                          [0, 0, 0, -1, 0, 0, 0, 0],
                          [0, 0, 1, 0, 0, 0, 0, 0],
                          [0, 0, 0, 0, 0, -1, 0, 0],
                          [0, 0, 0, 0, 1, 0, 0, 0],
                          [0, 0, 0, 0, 0, 0, 0, -1],
                          [0, 0, 0, 0, 0, 0, 1, 0]]"

abbreviation ZX:: "complex Matrix.mat" where
"ZX \<equiv> mat_of_cols_list 2 [[0, -1], [1, 0]]"

lemma l_inv_of_ZX:
  shows "ZX\<^sup>\<dagger> * ZX = 1\<^sub>m 2"
proof
  show "dim_row (ZX\<^sup>\<dagger> * ZX) = dim_row (1\<^sub>m 2)" using dagger_def mat_of_cols_list_def by simp
  show "dim_col (ZX\<^sup>\<dagger> * ZX) = dim_col (1\<^sub>m 2)" using dagger_def mat_of_cols_list_def by simp
  show "\<And>i j. i < dim_row (1\<^sub>m 2) \<Longrightarrow> j < dim_col (1\<^sub>m 2) \<Longrightarrow> (ZX\<^sup>\<dagger> * ZX) $$ (i, j) = 1\<^sub>m 2 $$ (i, j)"
  proof-
    fix i j assume "i < dim_row (1\<^sub>m 2)" and "j < dim_col (1\<^sub>m 2)"
    then have "i \<in> {0..<2} \<and> j \<in> {0..<2}" by auto
    then show "(ZX\<^sup>\<dagger> * ZX) $$ (i, j) = 1\<^sub>m 2 $$ (i, j)"
      using mat_of_cols_list_def dagger_def by (auto simp add: set_2)
  qed
qed

lemma r_inv_of_ZX:
  shows "ZX * (ZX\<^sup>\<dagger>) = 1\<^sub>m 2"
proof
  show "dim_row (ZX * (ZX\<^sup>\<dagger>)) = dim_row (1\<^sub>m 2)" using dagger_def mat_of_cols_list_def by simp
  show "dim_col (ZX * (ZX\<^sup>\<dagger>)) = dim_col (1\<^sub>m 2)" using dagger_def mat_of_cols_list_def by simp
  show "\<And>i j. i < dim_row (1\<^sub>m 2) \<Longrightarrow> j < dim_col (1\<^sub>m 2) \<Longrightarrow> (ZX * (ZX\<^sup>\<dagger>)) $$ (i, j) = 1\<^sub>m 2 $$ (i, j)"
  proof-
    fix i j assume "i < dim_row (1\<^sub>m 2)" and "j < dim_col (1\<^sub>m 2)"
    then have "i \<in> {0..<2} \<and> j \<in> {0..<2}" by auto
    then show "(ZX * (ZX\<^sup>\<dagger>)) $$ (i, j) = 1\<^sub>m 2 $$ (i, j)"
      using mat_of_cols_list_def dagger_def by (auto simp add: set_2)
  qed
qed

lemma ZX_is_gate [simp]:
  shows "gate 1 ZX"
proof
  show "dim_row ZX = 2 ^ 1" using mat_of_cols_list_def by simp
  show "square_mat ZX" using mat_of_cols_list_def by simp
  show "unitary ZX" using unitary_def l_inv_of_ZX r_inv_of_ZX mat_of_cols_list_def by auto
qed

lemma prod_of_ZX:
  shows "Z * X = ZX"
proof
  show "dim_row (Z * X) = dim_row ZX"
    using Z_is_gate mat_of_cols_list_def gate_def by auto
  show "dim_col (Z * X) = dim_col ZX"
    using X_is_gate mat_of_cols_list_def gate_def by auto
  show "\<And>i j. i < dim_row ZX \<Longrightarrow> j < dim_col ZX \<Longrightarrow> (Z * X) $$ (i, j) = ZX $$ (i, j)"
  proof-
    fix i j assume "i < dim_row ZX" and "j < dim_col ZX"
    then have "i \<in> {0..<2} \<and> j \<in> {0..<2}" by (auto simp add: mat_of_cols_list_def)
    then show "(Z * X) $$ (i, j) = ZX $$ (i, j)" by (auto simp add: set_2 Z_def X_def)
  qed
qed

lemma tensor_prod_of_id_2_y:
  shows "(Id 2 \<Otimes> Z * X) = M4"
proof
  have f0:"gate 3 (Id 2 \<Otimes> Z * X)"
    using prod_of_ZX ZX_is_gate tensor_gate[of "2" "Id 2" "1" "Z * X"] by simp
  then show "dim_row (Id 2 \<Otimes> Z * X) = dim_row M4"
      using gate_def by (simp add: mat_of_cols_list_def)
  show "dim_col (Id 2 \<Otimes> Z * X) = dim_col M4"
    using f0 gate_def by (simp add: mat_of_cols_list_def)
  show "\<And>i j. i < dim_row M4 \<Longrightarrow> j < dim_col M4 \<Longrightarrow> (Id 2 \<Otimes> Z * X) $$ (i,j) = M4 $$ (i,j)"
  proof-
    fix i j assume "i < dim_row M4" and "j < dim_col M4"
    then have "i \<in> {0..<8} \<and> j \<in> {0..<8}" by (auto simp add: mat_of_cols_list_def)
    then have "(Id 2 \<Otimes> ZX) $$ (i, j) = M4 $$ (i,j)"
      using Id_def mat_of_cols_list_def index_tensor_mat[of "Id 2" "4" "4" "ZX" "2" "2" "i" "j"]
        gate_def ZX_is_gate id_is_gate
      by (auto simp add: mat_of_cols_list_def)
    then show "(Id 2 \<Otimes> Z * X) $$ (i, j) = M4 $$ (i,j)"
      using prod_of_ZX by simp
    qed
qed

abbreviation M5:: "complex Matrix.mat" where
"M5 \<equiv> mat_of_cols_list 8 [[1, 0, 0, 0, 0, 0, 0, 0],
                          [0, -1, 0, 0, 0, 0, 0, 0],
                          [0, 0, 1, 0, 0, 0, 0, 0],
                          [0, 0, 0, -1, 0, 0, 0, 0],
                          [0, 0, 0, 0, 1, 0, 0, 0],
                          [0, 0, 0, 0, 0, -1, 0, 0],
                          [0, 0, 0, 0, 0, 0, 1, 0],
                          [0, 0, 0, 0, 0, 0, 0, -1]]"

lemma tensor_prod_of_id_2_z:
  shows "(Id 2 \<Otimes> Z) = M5"
proof
    have f0:"gate 3 (Id 2 \<Otimes> Z)"
      using Z_is_gate tensor_gate[of "2" "Id 2" "1" "Z"] by simp
    then show "dim_row (Id 2 \<Otimes> Z) = dim_row M5"
      using gate_def by (simp add:  mat_of_cols_list_def)
    show "dim_col (Id 2 \<Otimes> Z) = dim_col M5"
      using f0 gate_def by (simp add:  mat_of_cols_list_def)
    show "\<And>i j. i < dim_row M5 \<Longrightarrow> j < dim_col M5 \<Longrightarrow> (Id 2 \<Otimes> Z) $$ (i,j) = M5 $$ (i,j)"
    proof-
      fix i j assume "i < dim_row M5" and "j < dim_col M5"
      then have "i \<in> {0..<8} \<and> j \<in> {0..<8}" by (auto simp add: mat_of_cols_list_def)
      then show "(Id 2 \<Otimes> Z) $$ (i, j) = M5 $$ (i,j)"
        using Id_def Z_def index_tensor_mat[of "Id 2" "4" "4" "Z" "2" "2" "i" "j"] gate_def Z_is_gate
id_is_gate Id_def by (auto simp add: mat_of_cols_list_def Z_def)
    qed
qed

lemma teleportation:
  assumes "state 1 \<phi>" and "state 3 q" and "List.member (alice_meas \<phi>) (p, q)"
  shows "\<exists>r. state 2 r \<and> bob q (alice_out \<phi> q) = r \<Otimes> \<phi>"
proof-
  define \<alpha> \<beta> where a0:"\<alpha> = \<phi> $$ (0,0)" and a1:"\<beta> = \<phi> $$ (1,0)"
  then have "q = mat_of_cols_list 8 [[\<alpha>, \<beta>, 0, 0, 0, 0, 0, 0]] \<or>
             q = mat_of_cols_list 8 [[0, 0, \<beta>, \<alpha>, 0, 0, 0, 0]] \<or>
             q = mat_of_cols_list 8 [[0, 0, 0, 0, \<alpha>, -\<beta>, 0, 0]] \<or>
             q = mat_of_cols_list 8 [[0, 0, 0, 0, 0, 0, -\<beta>, \<alpha>]]"
    using assms Alice_case alice_pos_def by simp
  moreover have "q = mat_of_cols_list 8 [[\<alpha>,\<beta>,0,0,0,0,0,0]] \<Longrightarrow> bob q (alice_out \<phi> q) =
mat_of_cols_list 4 [[1, 0, 0, 0]] \<Otimes> \<phi>"
  proof
    assume asm:"q = Tensor.mat_of_cols_list 8 [[\<alpha>, \<beta>, 0, 0, 0, 0, 0, 0]]"
    show "dim_row (bob q (alice_out \<phi> q)) = dim_row (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm by simp
    show "dim_col (bob q (alice_out \<phi> q)) = dim_col (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm by simp
    show "\<And>i j. i < dim_row (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>) \<Longrightarrow>
                j < dim_col (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>) \<Longrightarrow>
           bob q (alice_out \<phi> q) $$ (i, j) = (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>) $$ (i,j)"
    proof-
      fix i j assume "i < dim_row (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>)" and
                     "j < dim_col (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>)"
      then have "i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def assms state_def by auto
      then show "bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[1,0,0,0]] \<Otimes> \<phi>) $$ (i,j)"
        using bob_def alice_out_def asm mat_of_cols_list_def a0 a1 assms state_def by auto
    qed
  qed
  moreover have "q = mat_of_cols_list 8 [[0,0,\<beta>,\<alpha>,0,0,0,0]] \<Longrightarrow> bob q (alice_out \<phi> q) =
mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>"
  proof
    assume asm:"q = Tensor.mat_of_cols_list 8 [[0,0,\<beta>,\<alpha>,0,0,0,0]]"
    show "dim_row (bob q (alice_out \<phi> q)) = dim_row (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm tensor_prod_of_id_2_x by simp
    show "dim_col (bob q (alice_out \<phi> q)) = dim_col (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm by simp
    show "\<And>i j. i < dim_row (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>) \<Longrightarrow>
                j < dim_col (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>) \<Longrightarrow>
           bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>) $$ (i,j)"
    proof-
      fix i j assume "i < dim_row (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>)" and
                     "j < dim_col (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>)"
      then have c1:"i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def assms(1) state_def by auto
      then have "(M3 * (Matrix.mat 8 1 (\<lambda>(i,j). [[0,0,\<phi> $$ (1,0),\<phi> $$ (0,0),0,0,0,0]]!j!i))) $$ (i,j) =
(Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>) $$ (i,j)"
        using state_def assms(1) by(auto simp add:  a0 a1 mat_of_cols_list_def times_mat_def scalar_prod_def)
      then show "bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,1,0,0]] \<Otimes> \<phi>) $$ (i,j)"
        using bob_def alice_out_def asm c1 a0 a1 mat_of_cols_list_def tensor_prod_of_id_2_x assms(1) by simp
    qed
  qed
  moreover have "q = mat_of_cols_list 8 [[0,0,0,0,\<alpha>,-\<beta>,0,0]] \<Longrightarrow> bob q (alice_out \<phi> q) =
mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>"
  proof
    assume asm:"q = Tensor.mat_of_cols_list 8 [[0,0,0,0,\<alpha>,-\<beta>,0,0]]"
    show "dim_row (bob q (alice_out \<phi> q)) = dim_row (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm tensor_prod_of_id_2_z by simp
    show "dim_col (bob q (alice_out \<phi> q)) = dim_col (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm by simp
    show "\<And>i j. i < dim_row (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>) \<Longrightarrow>
                j < dim_col (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>) \<Longrightarrow>
           bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>) $$ (i,j)"
    proof-
      fix i j assume "i < dim_row (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>)" and
                     "j < dim_col (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>)"
      then have c1:"i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def assms state_def by auto
      then have "(M5 * (Matrix.mat 8 (Suc 0) (\<lambda>(i,j). [[0,0,0,0,\<phi> $$ (0,0),-\<phi> $$ (Suc 0,0),0,0]]!j!i))) $$ (i,j) =
(Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>) $$ (i,j)"
        using state_def assms(1) by(auto simp add: a0 a1 mat_of_cols_list_def times_mat_def scalar_prod_def)
      then show "bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,0,1,0]] \<Otimes> \<phi>) $$ (i,j)"
        using bob_def alice_out_def asm c1 a0 a1 mat_of_cols_list_def tensor_prod_of_id_2_z assms(1) by simp
    qed
  qed
  moreover have "q = mat_of_cols_list 8 [[0, 0, 0, 0, 0, 0, -\<beta>, \<alpha>]] \<Longrightarrow> bob q (alice_out \<phi> q) =
mat_of_cols_list 4 [[0, 0, 0, 1]] \<Otimes> \<phi>"
  proof
    assume asm:"q = Tensor.mat_of_cols_list 8 [[0, 0, 0, 0, 0, 0, -\<beta>, \<alpha>]]"
    show "dim_row (bob q (alice_out \<phi> q)) = dim_row (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm tensor_prod_of_id_2_y by simp
    show "dim_col (bob q (alice_out \<phi> q)) = dim_col (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>)"
      using mat_of_cols_list_def a0 a1 assms(1) state_def bob_def alice_out_def asm by simp
    show "\<And>i j. i < dim_row (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>) \<Longrightarrow>
                j < dim_col (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>) \<Longrightarrow>
           bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>) $$ (i,j)"
    proof-
      fix i j assume "i < dim_row (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>)" and
                     "j < dim_col (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>)"
      then have c1:"i \<in> {0..<8} \<and> j = 0"
        using asm mat_of_cols_list_def assms state_def by auto
      then have "(M4 * (Matrix.mat 8 (Suc 0) (\<lambda>(i, j). [[0,0,0,0,0,0,-\<phi> $$ (Suc 0,0),\<phi> $$ (0,0)]]!j!i))) $$ (i,j) =
(Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>) $$ (i,j)"
        using state_def assms(1) by(auto simp add: a0 a1 mat_of_cols_list_def times_mat_def scalar_prod_def)
      then show "bob q (alice_out \<phi> q) $$ (i,j) = (Tensor.mat_of_cols_list 4 [[0,0,0,1]] \<Otimes> \<phi>) $$ (i,j)"
        using bob_def alice_out_def asm c1 a0 a1 mat_of_cols_list_def tensor_prod_of_id_2_y assms(1) by simp
    qed
  qed
  moreover have "state 2 (mat_of_cols_list 4 [[1, 0, 0, 0]])"
    using state_def mat_of_cols_list_def cpx_vec_length_def lessThan_atLeast0 by simp
  moreover have "state 2 (mat_of_cols_list 4 [[0, 1, 0, 0]])"
    using state_def mat_of_cols_list_def cpx_vec_length_def lessThan_atLeast0 by simp
  moreover have "state 2 (mat_of_cols_list 4 [[0, 0, 1, 0]])"
    using state_def mat_of_cols_list_def cpx_vec_length_def lessThan_atLeast0 by simp
  moreover have "state 2 (mat_of_cols_list 4 [[0, 0, 0, 1]])"
    using state_def mat_of_cols_list_def cpx_vec_length_def lessThan_atLeast0 by simp
  ultimately show ?thesis by auto
qed

(*
Biblio:

@inproceedings{Boender2015FormalizationOQ,
  title={Formalization of Quantum Protocols using Coq},
  author={Jaap Boender and Florian Kamm{\"u}ller and Rajagopal Nagarajan},
  booktitle={QPL},
  year={2015}
}
*)

end


theory Submission
  imports Defs
begin

definition indinv where
  "indinv st \<equiv> safe st \<and> (\<forall>i. Proc i \<longrightarrow> (pc st i = assign_y \<or> pc st i = finished) \<longrightarrow> x st i = 1)"

lemma Proc_mod :
  "\<forall> i. Proc i \<longrightarrow> Proc ((i + 1) mod N)"
  unfolding Proc_def by auto

lemma reachable_indinv :
  "indinv st" if "reachable st"
  using that
proof induction
  case (init init_x init_y)
  then show ?case
    using proc_0 by (auto simp: indinv_def safe_def)
next
  case (x_step st i)
  then show ?case
    by (auto simp: indinv_def safe_def update_x_def update_pc_def)
next
  case (y_step st i)
  then show ?case
    apply (auto simp: indinv_def safe_def update_y_def update_pc_def)
     apply (metis Proc_mod Suc_eq_plus1)+
    done
qed

theorem reachable_safe :
  "safe st" if "reachable st"
  using reachable_indinv[OF that] unfolding indinv_def ..

end


theory prop_28
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

hipster rev app
lemma lemma_a [thy_expl]: "app x2 NL.Nil = x2"
by (hipster_induct_schemes Listi.rev.simps Listi.app.simps)

lemma lemma_aa [thy_expl]: "app (app x1 y1) z1 = app x1 (app y1 z1)"
by (hipster_induct_schemes Listi.rev.simps Listi.app.simps)

lemma lemma_ab [thy_expl]: "app (Listi.rev x9) (Listi.rev y9) = Listi.rev (app y9 x9)"
by (hipster_induct_schemes Listi.rev.simps Listi.app.simps)

lemma lemma_ac [thy_expl]: "Listi.rev (Listi.rev x8) = x8"
by (hipster_induct_schemes Listi.rev.simps Listi.app.simps)

theorem palyn : "t = rev t \<Longrightarrow> rev (app t t) = app t t"
by (hipster_induct_schemes rev.simps app.simps)

end


theory HOML imports Main
begin
(*Type declarations and type abbreviations*)
typedecl i (*Possible worlds*)
typedecl e (*Individuals*)
type_synonym \<sigma> = "i\<Rightarrow>bool" (*World-lifted propositions*)
type_synonym \<gamma> = "e\<Rightarrow>\<sigma>" (*Lifted predicates*)
type_synonym \<mu> = "\<sigma>\<Rightarrow>\<sigma>" (*Unary modal connectives*)
type_synonym \<nu> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (*Binary modal connectives*)

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

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

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

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

(*Consistency, Barcan and converse Barcan formula*)
lemma True nitpick[satisfy] oops  (*Model found by Nitpick*)
lemma "\<lfloor>(\<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x))\<rfloor>" nitpick oops (*Ctm*)
lemma "\<lfloor>(\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x))) \<^bold>\<rightarrow> \<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x)\<rfloor>" nitpick oops (*Ctm*)
lemma "\<lfloor>(\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. \<phi> x)\<rfloor>" by simp
lemma "\<lfloor>(\<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x))) \<^bold>\<rightarrow> \<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)\<rfloor>" by simp

(*unimportant*) nitpick_params[user_axioms,show_all]
(*unimportant*) declare [[smt_solver=cvc4,smt_oracle]]
end


theory cw1q1

imports Main

begin

lemma 1: "A \<or> A \<longrightarrow> A"
  apply(rule impI)
  apply(erule disjE)
  by assumption

lemma 2: "A \<and> A \<longrightarrow> A"
  apply(rule impI)
  apply(erule conjE)
  by assumption

lemma 3: "(\<not>P \<or> R) \<longrightarrow> (P \<longrightarrow> R)"
  apply(rule impI)+
  apply(erule disjE)
   apply(erule notE)
  by assumption

lemma 4: "(\<exists>x. P x \<and> Q x) \<longrightarrow> (\<exists>x. P x) \<and> (\<exists>x. Q x)"
  apply(rule impI)
  apply(rule conjI)
   apply(erule exE)+
   apply(erule conjE)+
   apply(rule exI)
   apply(assumption)
  apply(erule exE)
  apply(erule conjE)
  apply(rule exI)
  by assumption

lemma 5: "(\<not>(\<exists>x. \<not>P x) \<or> R) \<longrightarrow> ((\<exists>x. \<not>P x) \<longrightarrow> R)"
  apply(rule impI)+
  apply(erule disjE)
   apply(erule exE)
   apply(erule notE)
   apply(rule exI)
   apply(rule notI)
   apply(erule notE)
   apply(assumption)
  apply(erule exE)
  by assumption

lemma 6: "(\<not>(\<exists>x. \<not>P x) \<or> R) \<longrightarrow> ((\<exists>x. \<not>P x) \<longrightarrow> R)"
  apply(rule impI)+
  apply(erule disjE)
  apply(erule exE)
   apply(erule notE)
   apply(rule exI)
   apply(rule notI)
   apply(erule notE)
   apply(assumption)
  apply(erule exE)
  by assumption

lemma 7: "(\<forall>x. P x) \<longrightarrow> \<not>(\<exists>x. \<not>P x)"
  apply(rule impI)
  apply(rule notI)
  apply(erule exE)
  apply(erule allE)
  apply(erule notE)
  by assumption

lemma 8: "P \<or> \<not>P"
  apply(rule disjCI)
  apply(rule ccontr)
  apply(erule notE)
  by assumption

lemma 9: "\<not>\<not>P \<longrightarrow> P"
  apply(rule impI)
  apply(rule mp)
   apply(rule impI)
   apply auto
  sorry

lemma 10: "(\<not>P \<longrightarrow> P) \<longrightarrow> P"

lemma 11: "(\<not>P \<longrightarrow> False)\<longrightarrow>P"

lemma 12: "(\<not>(\<forall>x. P x \<or> R x)) = (\<exists>x. \<not>P x \<and> \<not>R x)"

lemma 13: "(\<exists>x. P x \<or> R x) = (\<not>((\<forall>x. \<not>P x) \<and> \<not>(\<exists>x. R x)))"

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: utp_dvar.thy                                                         *)
(* Authors: Simon Foster and Frank Zeyda (University of York, UK)             *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

subsection \<open>Deep Variables\<close>

theory utp_dvar
  imports
  "UTP1.utp"
  "Continuum.Continuum"
begin recall_syntax

text \<open>
  UTP variables represented by record fields are shallow, nameless entities. They are fundamentally
  static in nature, since a new record field can only be introduced definitionally and cannot be
  otherwise arbitrarily created. They are nevertheless very useful as proof automation is excellent,
  and they can fully make use of the Isabelle type system. However, for constructs like alphabet
  extension that can introduce new variables they are inadequate. As a result we also introduce
  a notion of deep variables to complement them. A deep variable is not a record field, but
  rather a key within a store map that records the values of all deep variables. As such the
  Isabelle type system is agnostic of them, and the creation of a new deep variable does not
  change the portion of the alphabet specified by the type system.

  In order to create a type of stores (or bindings) for variables, we must fix a universe
  for the variable valuations. This is the major downside of deep variables -- they cannot
  have any type, but only a type whose cardinality is up to $\mathfrak{c}$, the cardinality
  of the continuum. This is why we need both deep and shallow variables, as the latter are
  unrestricted in this respect. Each deep variable will therefore specify the cardinality
  of the type it possesses.
\<close>

subsection \<open>Cardinalities\<close>

text \<open>
  We first fix a datatype representing all possible cardinalities for a deep variable. These
  include finite cardinalities, $\aleph_0$ (countable), and $\mathfrak{c}$ (uncountable up
  to the continuum).
\<close>

datatype ucard = fin nat | aleph0 ("\<aleph>\<^sub>0") | cont ("\<c>")

text \<open>
  Our universe is simply the set of natural numbers; this is sufficient for all types up
  to cardinality $\mathfrak{c}$.
\<close>

type_synonym uuniv = "nat set"

text \<open>
  We introduce a function that gives the set of values within our universe of the given
  cardinality. Since a cardinality of 0 is no proper type, we use finite cardinality 0 to
  mean cardinality 1, 1 to mean 2 etc.
\<close>

fun uuniv :: "ucard \<Rightarrow> uuniv set" ("\<U>'(_')") where
"\<U>(fin n) = {{x} | x. x \<le> n}" |
"\<U>(\<aleph>\<^sub>0) = {{x} | x. True}" |
"\<U>(\<c>) = UNIV"

text \<open>
  We also define the following function that gives the cardinality of a type within
  the @{class continuum} type class.
\<close>

definition ucard_of :: "'a::continuum itself \<Rightarrow> ucard" where
"ucard_of x = (if (finite (UNIV :: 'a set))
                  then fin(card(UNIV :: 'a set) - 1)
               else if (countable (UNIV :: 'a set))
                  then \<aleph>\<^sub>0
               else \<c>)"

syntax
  "_ucard" :: "type \<Rightarrow> ucard" ("UCARD'(_')")

translations
  "UCARD('a)" == "CONST ucard_of (TYPE('a))"

lemma ucard_non_empty:
  "\<U>(x) \<noteq> {}"
  by (induct x, auto)

lemma ucard_of_finite [simp]:
  "finite (UNIV :: 'a::continuum set) \<Longrightarrow> UCARD('a) = fin(card(UNIV :: 'a set) - 1)"
  by (simp add: ucard_of_def)

lemma ucard_of_countably_infinite [simp]:
  "\<lbrakk> countable(UNIV :: 'a::continuum set); infinite(UNIV :: 'a set) \<rbrakk> \<Longrightarrow> UCARD('a) = \<aleph>\<^sub>0"
  by (simp add: ucard_of_def)

lemma ucard_of_uncountably_infinite [simp]:
  "uncountable (UNIV :: 'a set) \<Longrightarrow> UCARD('a :: continuum) = \<c>"
  apply (simp add: ucard_of_def)
  using countable_finite apply blast
done

subsection \<open> Injection functions \<close>

definition uinject_finite :: "'a::finite \<Rightarrow> uuniv" where
"uinject_finite x = {to_nat_fin x}"

definition uinject_aleph0 :: "'a::{countable, infinite} \<Rightarrow> uuniv" where
"uinject_aleph0 x = {to_nat_bij x}"

definition uinject_continuum :: "'a::{continuum, infinite} \<Rightarrow> uuniv" where
"uinject_continuum x = to_nat_set_bij x"

definition uinject :: "'a::continuum \<Rightarrow> uuniv" where
"uinject x = (if (finite (UNIV :: 'a set))
                 then {to_nat_fin x}
               else if (countable (UNIV :: 'a set))
                  then {to_nat_on (UNIV :: 'a set) x}
               else to_nat_set x)"

definition uproject :: "uuniv \<Rightarrow> 'a::continuum" where
"uproject = inv uinject"

lemma uinject_finite:
  "finite (UNIV :: 'a::continuum set) \<Longrightarrow> uinject = (\<lambda> x :: 'a. {to_nat_fin x})"
  by (rule ext, auto simp add: uinject_def)

lemma uinject_uncountable:
  "uncountable (UNIV :: 'a::continuum set) \<Longrightarrow> (uinject :: 'a \<Rightarrow> uuniv) = to_nat_set"
  by (rule ext, auto simp add: uinject_def countable_finite)

lemma card_finite_lemma:
  assumes "finite (UNIV :: 'a set)"
  shows "x < card (UNIV :: 'a set) \<longleftrightarrow> x \<le> card (UNIV :: 'a set) - Suc 0"
proof -
  have "card (UNIV :: 'a set) > 0"
    by (simp add: assms finite_UNIV_card_ge_0)
  thus ?thesis
    by linarith
qed

text \<open> This is a key theorem that shows that the injection function provides a bijection between
        any continuum type and the subuniverse of types with a matching cardinality. \<close>

lemma uinject_bij:
  "bij_betw (uinject :: 'a::continuum \<Rightarrow> uuniv) UNIV \<U>(UCARD('a))"
proof (cases "finite (UNIV :: 'a set)")
  case True thus ?thesis
    apply (auto simp add: uinject_def bij_betw_def inj_on_def image_def card_finite_lemma[THEN sym])
    apply (auto simp add: inj_eq to_nat_fin_inj to_nat_fin_bounded)
    using to_nat_fin_ex apply blast
  done
  next
  case False note infinite = this thus ?thesis
  proof (cases "countable (UNIV :: 'a set)")
    case True thus ?thesis
      apply (auto simp add: uinject_def bij_betw_def inj_on_def infinite image_def card_finite_lemma[THEN sym])
      apply (meson image_to_nat_on infinite surj_def)
    done
    next
    case False note uncount = this thus ?thesis
      apply (simp add: uinject_uncountable)
      using to_nat_set_bij apply blast
    done
  qed
qed

lemma uinject_card [simp]: "uinject (x :: 'a::continuum) \<in> \<U>(UCARD('a))"
  by (metis bij_betw_def rangeI uinject_bij)

lemma uinject_inv [simp]:
  "uproject (uinject x) = x"
  by (metis UNIV_I bij_betw_def inv_into_f_f uinject_bij uproject_def)

lemma uproject_inv [simp]:
  "x \<in> \<U>(UCARD('a::continuum)) \<Longrightarrow> uinject ((uproject :: nat set \<Rightarrow> 'a)  x) = x"
  by (metis bij_betw_inv_into_right uinject_bij uproject_def)

subsection \<open> Deep variables \<close>

text \<open> A deep variable name stores both a name and the cardinality of the type it points to \<close>

record dname =
  dname_name :: "string"
  dname_card :: "ucard"

declare dname.splits [alpha_splits]

text \<open> A vstore is a function mapping deep variable names to corresponding values in the universe, such
        that the deep variables specified cardinality is matched by the value it points to. \<close>

typedef vstore = "{f :: dname \<Rightarrow> uuniv. \<forall> x. f(x) \<in> \<U>(dname_card x)}"
  apply (rule_tac x="\<lambda> x. {0}" in exI)
  apply (auto)
  apply (rename_tac x)
  apply (case_tac "dname_card x")
  apply (simp_all)
done

setup_lifting type_definition_vstore

typedef ('a::continuum) dvar = "{x :: dname. dname_card x = UCARD('a)}"
  morphisms dvar_dname Abs_dvar
  by (auto, meson dname.select_convs(2))

setup_lifting type_definition_dvar

lift_definition mk_dvar :: "string \<Rightarrow> ('a::{continuum,two}) dvar" ("\<lceil>_\<rceil>\<^sub>d")
is "\<lambda> n. \<lparr> dname_name = n, dname_card = UCARD('a) \<rparr>"
  by auto

lift_definition dvar_name :: "'a::continuum dvar \<Rightarrow> string" is "dname_name" .
lift_definition dvar_card :: "'a::continuum dvar \<Rightarrow> ucard" is "dname_card" .

lemma dvar_name [simp]: "dvar_name \<lceil>x\<rceil>\<^sub>d = x"
  by (transfer, simp)

setup_lifting type_definition_lens_ext

lift_definition dvar_get :: "('a::continuum) dvar \<Rightarrow> vstore \<Rightarrow> 'a"
is "\<lambda> x s. (uproject :: uuniv \<Rightarrow> 'a) (s(x))" .

lift_definition dvar_put :: "('a::continuum) dvar \<Rightarrow> vstore \<Rightarrow> 'a \<Rightarrow> vstore"
is "\<lambda> (x :: dname) f (v :: 'a). f(x := uinject v)"
  by (auto)

definition dvar_lens :: "('a::continuum) dvar \<Rightarrow> ('a \<Longrightarrow> vstore)" where
"dvar_lens x = \<lparr> lens_get = dvar_get x, lens_put = dvar_put x \<rparr>"

lemma vstore_vwb_lens [simp]:
  "vwb_lens (dvar_lens x)"
  apply (unfold_locales)
  apply (simp_all add: dvar_lens_def)
  apply (transfer, auto)
  apply (transfer)
  apply (metis fun_upd_idem uproject_inv)
  apply (transfer, simp)
done

lemma dvar_lens_indep_iff:
  fixes x :: "'a::{continuum,two} dvar" and y :: "'b::{continuum,two} dvar"
  shows "dvar_lens x \<bowtie> dvar_lens y \<longleftrightarrow> (dvar_dname x \<noteq> dvar_dname y)"
proof -
  obtain v1 v2 :: "'b::{continuum,two}" where v:"v1 \<noteq> v2"
    using two_diff by auto
  obtain u :: "'a::{continuum,two}" and v :: "'b::{continuum,two}"
    where uv: "uinject u \<noteq> uinject v"
    by (metis (full_types) uinject_inv v)
  show ?thesis
  proof (simp add: dvar_lens_def lens_indep_def, transfer, auto simp add: fun_upd_twist)
    fix y :: dname
    assume a1: "ucard_of (TYPE('b)::'b itself) = ucard_of (TYPE('a)::'a itself)"
    assume "dname_card y = ucard_of (TYPE('a)::'a itself)"
    assume a2:
      "\<forall> \<sigma>. (\<forall>x. \<sigma> x \<in> \<U>(dname_card x)) \<longrightarrow> (\<forall> v u. \<sigma>(y := uinject (u::'a)) = \<sigma>(y := uinject (v::'b)))"
      "\<forall> \<sigma>. (\<forall>x. \<sigma> x \<in> \<U>(dname_card x)) \<longrightarrow> (\<forall> v. (uproject (uinject v)::'a) = uproject (\<sigma> y))"
      "\<forall> \<sigma>. (\<forall>x. \<sigma> x \<in> \<U>(dname_card x)) \<longrightarrow> (\<forall> u. (uproject (uinject u)::'b) = uproject (\<sigma> y))"
    obtain NN :: "vstore \<Rightarrow> dname \<Rightarrow> nat set" where
      "\<And>v. \<forall>d. NN v d \<in> \<U>(dname_card d)"
      by (metis (lifting) Abs_vstore_cases mem_Collect_eq)
    then show False
      using a2 a1 by (metis fun_upd_same uv)
  qed
qed

text \<open> The vst class provides the location of the store in a larger type via a lens \<close>

class vst =
  fixes vstore_lens :: "vstore \<Longrightarrow> 'a" ("\<V>")
  assumes vstore_vwb_lens [simp]: "vwb_lens vstore_lens"

definition dvar_lift :: "'a::continuum dvar \<Rightarrow> ('a \<Longrightarrow> '\<alpha>::vst)" ("_\<up>" [999] 999) where
"dvar_lift x = dvar_lens x ;\<^sub>L vstore_lens"

definition [simp]: "in_dvar x = in_var (x\<up>)"
definition [simp]: "out_dvar x = out_var (x\<up>)"

lemma uvar_dvar: "vwb_lens (x\<up>)"
  by (auto intro: comp_vwb_lens simp add: dvar_lift_def)

text \<open> Deep variables with different names are independent \<close>

lemma dvar_lift_indep_iff:
  fixes x :: "'a::{continuum,two} dvar" and y :: "'b::{continuum,two} dvar"
  shows "x\<up> \<bowtie> y\<up> \<longleftrightarrow> dvar_dname x \<noteq> dvar_dname y"
proof -
  have "x\<up> \<bowtie> y\<up> \<longleftrightarrow> dvar_lens x \<bowtie> dvar_lens y"
    by (metis dvar_lift_def lens_comp_indep_cong_left lens_indep_left_comp vst_class.vstore_vwb_lens vwb_lens_mwb)
  also have "... \<longleftrightarrow> dvar_dname x \<noteq> dvar_dname y"
    by (simp add: dvar_lens_indep_iff)
  finally show ?thesis .
qed

lemma dvar_indep_diff_name' [simp]:
  "x \<noteq> y \<Longrightarrow> \<lceil>x\<rceil>\<^sub>d\<up> \<bowtie> \<lceil>y\<rceil>\<^sub>d\<up>"
  by (simp add: dvar_lift_indep_iff mk_dvar.rep_eq)

text \<open> A basic record structure for vstores \<close>

record vstore_d =
  vstore :: vstore

instantiation vstore_d_ext :: (type) vst
begin
  definition "vstore_lens_vstore_d_ext = FLDLENS vstore"
instance
  by (intro_classes, unfold_locales, simp_all add: vstore_lens_vstore_d_ext_def)
end

syntax
  "_sin_dvar"  :: "id \<Rightarrow> svar" ("%_" [999] 999)
  "_sout_dvar" :: "id \<Rightarrow> svar" ("%_\<acute>" [999] 999)

translations
  "_sin_dvar x"  => "CONST in_dvar (CONST mk_dvar IDSTR(x))"
  "_sout_dvar x" => "CONST out_dvar (CONST mk_dvar IDSTR(x))"

definition "MkDVar x = \<lceil>x\<rceil>\<^sub>d\<up>"

lemma uvar_MkDVar [simp]: "vwb_lens (MkDVar x)"
  by (simp add: MkDVar_def uvar_dvar)

lemma MkDVar_indep [simp]: "x \<noteq> y \<Longrightarrow> MkDVar x \<bowtie> MkDVar y"
  apply (rule lens_indepI)
  apply (simp_all add: MkDVar_def)
  apply (meson dvar_indep_diff_name' lens_indep_comm)
done

lemma MkDVar_put_comm [simp]:
  "m <\<^sub>l n \<Longrightarrow> put\<^bsub>MkDVar n\<^esub> (put\<^bsub>MkDVar m\<^esub> s u) v = put\<^bsub>MkDVar m\<^esub> (put\<^bsub>MkDVar n\<^esub> s v) u"
  by (simp add: lens_indep_comm)

text \<open> Set up parsing and pretty printing for deep variables \<close>

syntax
  "_dvar"     :: "id \<Rightarrow> svid" ("<_>")
  "_dvar_ty"  :: "id \<Rightarrow> type \<Rightarrow> svid" ("<_::_>")
  "_dvard"    :: "id \<Rightarrow> logic" ("<_>\<^sub>d")
  "_dvar_tyd" :: "id \<Rightarrow> type \<Rightarrow> logic" ("<_::_>\<^sub>d")

translations
  "_dvar x" => "CONST MkDVar IDSTR(x)"
  "_dvar_ty x a" => "_constrain (CONST MkDVar IDSTR(x)) (_uvar_ty a)"
  "_dvard x" => "CONST MkDVar IDSTR(x)"
  "_dvar_tyd x a" => "_constrain (CONST MkDVar IDSTR(x)) (_uvar_ty a)"

print_translation \<open>
let fun MkDVar_tr' _ [name] =
       Const (@{syntax_const "_dvar"}, dummyT) $
         Name_Utils.mk_id (HOLogic.dest_string (Name_Utils.deep_unmark_const name))
    | MkDVar_tr' _ _ = raise Match in
  [(@{const_syntax "MkDVar"}, MkDVar_tr')]
end
\<close>

definition dvar_exp :: "'t::continuum dvar \<Rightarrow> ('t, '\<alpha>::vst) uexpr"
where "dvar_exp x = utp_expr.var (dvar_lift x)"

definition unrest_dvar_upred :: "'a::continuum dvar \<Rightarrow> ('b, '\<alpha>::vst) uexpr \<Rightarrow> bool" where
"unrest_dvar_upred x P = unrest_uexpr (x\<up>) P"

definition subst_upd_dvar :: "('\<alpha>,'\<beta>::vst) psubst \<Rightarrow> 'a::continuum dvar \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst" where
"subst_upd_dvar \<sigma> x v = subst_upd \<sigma> (x\<up>) v"

declare subst_upd_dvar_def [upred_defs]

end


(*************************************************************************
 * Copyright (C)
 *               2019-2023 The University of Exeter
 *               2018-2023 The University of Paris-Saclay
 *               2018      The University of Sheffield
 *
 * License:
 *   This program can be redistributed and/or modified under the terms
 *   of the 2-clause BSD-style license.
 *
 *   SPDX-License-Identifier: BSD-2-Clause
 *************************************************************************)

chapter\<open>Ontologys Matching\<close>

theory Ontology_Matching_Example
  imports TestKit
          "Isabelle_DOF.Isa_DOF"
          "Isabelle_DOF-Unit-Tests_document"

begin

section\<open>Test Purpose.\<close>
text\<open> This is merely an example that shows that the generated invariants
      fit nicely together; i.e. allow for sensible consistency and invariant
      preservation proofs related to ontological matchings. \<close>

section\<open>The Scenario.\<close>

text\<open>Using HOL, we can define a mapping between two ontologies.
  It is called ontology matching or ontology alignment.
  Here is an example which show how to map two classes.
  HOL also allows us to map the invariants (ontological rules) of the classes!\<close>

type_synonym UTF8 = string

definition utf8_to_string
  where "utf8_to_string xx = xx"

doc_class A =
  first_name  :: UTF8
  last_name   :: UTF8
  age         :: nat
  married_to  :: "string option"
  invariant a :: "age \<sigma> < 18 \<longrightarrow> married_to \<sigma> = None"

doc_class B =
  name        :: string
  adult       :: bool
  is_married  :: bool
  invariant b :: "is_married \<sigma> \<longrightarrow> adult \<sigma>"

text\<open>We define the mapping between the two classes,
  i.e. how to transform the class @{doc_class A} in to the class @{doc_class B}:\<close>

definition A_to_B_morphism
  where "A_to_B_morphism X =
        \<lparr> tag_attribute = A.tag_attribute X
          , name = utf8_to_string (first_name X) @ '' ''  @ utf8_to_string (last_name X)
          , adult = (age X \<ge> 18)
          , is_married = (married_to X \<noteq> None) \<rparr>"

text\<open>Sanity check: Invariants are non-contradictory, i.e. there is a witness.\<close>

lemma inv_a_satisfyable : " Ex (a_inv::A \<Rightarrow> bool)"
  unfolding a_inv_def
  apply(rule_tac x ="\<lparr>Ontology_Matching_Example.A.tag_attribute = xxx,
                      first_name = yyy, last_name = zzz, age = 17,
                      married_to = None\<rparr>" in exI)
  by auto

text\<open>Now we check that the invariant is preserved through the morphism:\<close>

lemma inv_a_preserved :
  "a_inv X \<Longrightarrow> b_inv (A_to_B_morphism X)"
  unfolding a_inv_def b_inv_def A_to_B_morphism_def
  by auto

text\<open>This also implies that B invariants are non-contradictory: \<close>

lemma inv_b_preserved : "\<exists>x. (b_inv::B \<Rightarrow> bool) x"
   apply(rule_tac x ="A_to_B_morphism \<lparr>Ontology_Matching_Example.A.tag_attribute = xxx,
                                       first_name = yyy, last_name = zzz, age = 17,
                                        married_to = None\<rparr>" in exI)
   by(rule inv_a_preserved,auto simp: a_inv_def)

lemma A_morphism_B_total :
  "A_to_B_morphism ` ({X::A. a_inv X}) \<subseteq> ({X::B. b_inv X})"
  using inv_a_preserved
  by auto

end


theory polygon
imports cyclePath
begin

(*definition for polygon: intersectionfree cyclePath*)
definition polygon :: "point2d list \<Rightarrow> bool" where
  "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> polygon P \<equiv> intersectionFreePList P"
lemma notPolygon: "pointList [A,B,C] \<Longrightarrow> A isBetween C B \<Longrightarrow> polygon (cyclePath [A,B,C]) \<Longrightarrow> False"
  apply (subgoal_tac "segment B C \<and> segment A B")
  apply(simp add: cyclePath_def polygon_def intersectionFreePList_def isBetweenImpliesCollinear)
  apply (erule_tac x=1 in allE, erule_tac x=0 in allE, simp)
  using intersectBetween intersectSym1 apply blast
by (simp add: isBetweenPointsDistinct segment_def)

(*List with polygons*)
definition polygonList :: "(point2d list) list \<Rightarrow> bool" where
  "pointLists PL \<Longrightarrow> polygonList PL \<equiv> \<forall> i < length PL. polygon (cyclePath (PL!i))"
(*jedes element ist ein polygon*)
lemma polygonListSimp[simp]: "pointLists PL \<Longrightarrow> i < length PL  \<Longrightarrow> polygonList PL \<Longrightarrow>
    polygon (cyclePath (PL!i))"
  by (simp add: polygonList_def)
lemma polygonListSimp1: "pointLists [A,B] \<Longrightarrow> (polygon (cyclePath A) \<and> polygon (cyclePath B))
    = polygonList [A,B]"
  apply (simp del: polygonListSimp add: polygonList_def, auto)
by (case_tac i, auto)
lemma polygonListSimp2 [simp]: "pointLists [A] \<Longrightarrow> polygon (cyclePath A) = polygonList [A]"
  by (auto simp add: polygonList_def)

(*convex Polygon:
- none of the edges of the polygon separates any of the remaining corners of the polygon
- 3 consecutive edges are not collinear*)
(*Note: in cyclepath there collinearität here. Namely, at the first edge + the last*)
definition cPolygon :: "point2d list \<Rightarrow> bool" where
"pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon P \<equiv> (\<forall> k < length P - 1.
  \<not>(\<exists> i. i < length P - 1 \<and> lineSeparate (P ! k) (P ! Suc k) (P ! i) (P ! Suc i)))"

lemma cPolygonRevEq: "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon (rev P) \<equiv>
  (\<forall> k < length (rev P) - 1.
  \<not>(\<exists> i. i < length (rev P) - 1 \<and> lineSeparate ((rev P) ! k) ((rev P) ! Suc k) ((rev P) ! i) ((rev P) ! Suc i)))"
  apply (cut_tac P="rev P" and L="hd L # rev (tl L)" in cPolygon_def, simp,simp add: cyclePath_def)
oops
lemma cPolygonRev: "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon P \<Longrightarrow>
    cPolygon (rev P)"
oops

(*all triangles are conv. polygon*)
lemma conVextriangles: "pointList L \<Longrightarrow> length L = 3 \<Longrightarrow> \<not>collinearList L \<Longrightarrow>
  P = cyclePath L \<Longrightarrow> cPolygon P"
  apply (simp add:cPolygon_def cyclePath_def, safe)
  apply (simp add: lineSeparate_def, safe)
  apply (subgoal_tac "(k=0 \<and> i = 2) \<or> (k=1 \<and> i = 0) \<or> (k=2 \<and> i = 1)", safe)
    apply (auto simp add: rightTurn_def)
    apply (metis Nil_is_append_conv areaDoublePoint2 hd_append2 hd_conv_nth less_numeral_extra(3)
      list.size(3) nth_append_length signedAreaRotate)
    apply (metis add_2_eq_Suc' areaDoublePoint less_numeral_extra(3)
      monoid_add_class.add.left_neutral signedAreaRotate)
    apply (metis areaDoublePoint2 less_2_cases less_Suc_eq less_numeral_extra(3)
      numeral_eq_Suc pred_numeral_simps(3))
    apply (smt Nil_is_append_conv Suc_lessI areaDoublePoint hd_append2 hd_conv_nth signedAreaRotate
      length_greater_0_conv neq0_conv not_less_iff_gr_or_eq nth_append_length numeral_3_eq_3)
    apply (metis areaDoublePoint2 less_2_cases less_Suc_eq not_less_iff_gr_or_eq numeral_eq_Suc
      pred_numeral_simps(3))
    apply (smt Suc_1 Suc_eq_plus1_left areaDoublePoint2 less_2_cases less_Suc_eq
      less_numeral_extra(3) monoid_add_class.add.right_neutral numeral_3_eq_3)
    apply (metis colliniearRight less_2_cases less_Suc_eq less_numeral_extra(3)
      notCollThenDiffPoints numeral_eq_Suc pred_numeral_simps(3))
    apply (smt Nil_is_append_conv Suc_eq_plus1_left areaDoublePoint hd_append2 hd_conv_nth
      length_greater_0_conv less_Suc_eq less_nat_zero_code less_numeral_extra(3) nth_append_length
      numeral_3_eq_3 signedAreaRotate)
  apply (subgoal_tac "(k=0 \<and> i = 2) \<or> (k=1 \<and> i = 0) \<or> (k=2 \<and> i = 1)", auto)
    apply (metis Nil_is_append_conv areaDoublePoint2 hd_append2 hd_conv_nth less_numeral_extra(3)
      list.size(3) nth_append_length signedAreaRotate)
    apply (metis add_2_eq_Suc' areaDoublePoint less_numeral_extra(3)
      monoid_add_class.add.left_neutral)
    apply (metis areaDoublePoint2 less_2_cases less_Suc_eq less_numeral_extra(3)
      numeral_eq_Suc pred_numeral_simps(3))
    apply (smt Nil_is_append_conv Suc_lessI areaDoublePoint hd_append2 hd_conv_nth signedAreaRotate
      length_greater_0_conv neq0_conv not_less_iff_gr_or_eq nth_append_length numeral_3_eq_3)
    apply (metis areaDoublePoint2 less_2_cases less_Suc_eq not_less_iff_gr_or_eq numeral_eq_Suc
      pred_numeral_simps(3))
    apply (smt Suc_1 Suc_eq_plus1_left areaDoublePoint2 less_2_cases less_Suc_eq
      less_numeral_extra(3) monoid_add_class.add.right_neutral numeral_3_eq_3)
    apply (metis colliniearRight less_2_cases less_Suc_eq less_numeral_extra(3)
      notCollThenDiffPoints numeral_eq_Suc pred_numeral_simps(3))
    apply (smt Nil_is_append_conv Suc_eq_plus1_left areaDoublePoint hd_append2 hd_conv_nth
      length_greater_0_conv less_Suc_eq less_nat_zero_code less_numeral_extra(3) nth_append_length
      numeral_3_eq_3 signedAreaRotate)
done

(*in a conv. polygon none of the lines intersects*)
theorem cPolygonIsCrossingFree: "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
    cPolygon P \<Longrightarrow> crossingFreePList P"
  apply (simp add: crossingFreePList_def, safe, simp add: cPolygon_def)
  apply (erule_tac x=k in allE, simp, erule_tac x=i in allE, simp)
  apply (simp add: lineSeparate_def, safe, auto simp add: conflictingRigthTurns)
by(metis collRotate crossingCollinear crossingSym1 crossingRightTurn crossingSym rightTurnRotate2)+
(*no 2 adjacent segment intersect, if cPolygon*)
lemma cPolygonIntersectAdj:"pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
  cPolygon P \<Longrightarrow> a < length P - 2 \<Longrightarrow> \<not>intersect (P ! a) (P! Suc a) (P! Suc a) (P! Suc(Suc a))"
  apply (auto simp add: intersect_def)
  using Suc_mono Suc_pred colliniearRight cyclePathNotCollinear1 isBetweenImpliesCollinear3
  length_greater_0_conv less_diff_conv apply fastforce
using Suc_mono colliniearRight cyclePathNotCollinear1 isBetweenImpliesCollinear
  less_diff_conv by fastforce
(*in a conv. polygon none of the lines intersects(real)*)
theorem cPolygonIsIntersectionFree : "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
    cPolygon P \<Longrightarrow> intersectionFreePList P"
  apply (auto simp add: intersectionFreePList_def intersect_def)
  apply (metis Suc_eq_plus1 Suc_mono cPolygon_def crossing_def cyclePath_def
    length_append_singleton less_diff_conv)
by (metis Suc_mono cyclePathNotCollinear cyclePath_def isBetweenImpliesCollinear
  isBetweenPointsDistinct length_append_singleton less_SucI)+

(*each conv. polygon is also a simple polygon*)
theorem cPolygonIsPolygon : "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>
    cPolygon P \<Longrightarrow> polygon P"
    by (auto simp add: cPolygonIsIntersectionFree polygon_def)

(*evtl. noch nützlich*)

(*(*count how many times a track intersects the polygon*)
fun countSegmentCrossPolygon :: "point2d list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> nat" where
  "countSegmentCrossPolygon [] S E = 0"
  | "countSegmentCrossPolygon [P] S E = 0"
  | "countSegmentCrossPolygon (Pf#Pl#Ps) S E = (if (crossing Pf Pl S E)
    then (1 + countSegmentCrossPolygon (Pl#Ps) S E)
    else(countSegmentCrossPolygon (Pl#Ps) S E))"

(*When is a point in a polygon?*)
definition pointInPolygon :: "point2d list \<Rightarrow> point2d \<Rightarrow> bool" where
  "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> polygon P \<Longrightarrow> pointInPolygon P A \<equiv>
    odd(countSegmentCrossPolygon P A (Abs_point2d(xCoord (last(xCoordSort P)) + 1, yCoord A)))" (*austauschen durch unendlich*)

(*polygon is partial or complete in another Polygon*)
definition polygonInPolygon :: "point2d list \<Rightarrow> point2d list \<Rightarrow> bool" where
  "pointList Lr\<Longrightarrow> Pr=cyclePath Lr\<Longrightarrow> polygon Pr\<Longrightarrow> pointList Lt\<Longrightarrow>Pt=cyclePath Lt \<Longrightarrow> polygon Pt\<Longrightarrow>
    polygonInPolygon Pr Pt \<equiv> (\<exists> i \<in> set Pr. pointInPolygon Pt i)
    \<or> (\<exists> j \<in> set Pt. pointInPolygon Pr j)"

lemma polygonInPolygonSym : "pointList Lr \<Longrightarrow> Pr = cyclePath Lr \<Longrightarrow> polygon Pr \<Longrightarrow> pointList Lt \<Longrightarrow>
  Pt = cyclePath Lt \<Longrightarrow> polygon Pt \<Longrightarrow> polygonInPolygon Pr Pt = polygonInPolygon Pt Pr"
  by (simp add: polygonInPolygon_def, rule iffI, blast+)
lemma polygonInPolygonSame: "pointList Lr \<Longrightarrow> Pr=cyclePath Lr \<Longrightarrow>polygon Pr \<Longrightarrow>
  polygonInPolygon Pr Pr \<Longrightarrow> False"
  apply (auto simp add: polygonInPolygon_def pointInPolygon_def)
sorry

lemma polygonCrossing : "pointList Lr \<Longrightarrow> Pr = cyclePath Lr \<Longrightarrow> polygon Pr \<Longrightarrow> pointList Lt \<Longrightarrow>
    Pt = cyclePath Lt \<Longrightarrow> polygon Pt \<Longrightarrow> cyclePathIntersect Pr Pt \<Longrightarrow> \<not>polygonInPolygon Pr Pt"
sorry

definition polygonDisjoint :: "point2d list \<Rightarrow> point2d list \<Rightarrow> bool" where
  "pointList Ll\<Longrightarrow> P=cyclePath Ll\<Longrightarrow> polygon P \<Longrightarrow> pointList Lr\<Longrightarrow> R=cyclePath Lr \<Longrightarrow> polygon R \<Longrightarrow>
    polygonDisjoint P R \<equiv> \<not>polygonInPolygon P R \<and> \<not>cyclePathIntersect P R"(*point on Segment case*)
(*polygon ist zu sich selbst nicht disjoint*)
lemma polygonDisjointSame: "pointList Ll\<Longrightarrow> P=cyclePath Ll\<Longrightarrow> polygon P \<Longrightarrow>
  polygonDisjoint P P \<Longrightarrow> False"
  apply (simp add: polygonDisjoint_def, safe)
using cyclePathIntersectSame by blast
lemma polygonDisjointSame1: "pointList Ll\<Longrightarrow> P=cyclePath Ll\<Longrightarrow> polygon P \<Longrightarrow> pointList Lr\<Longrightarrow>
    R=cyclePath Lr \<Longrightarrow> polygon R \<Longrightarrow> polygonDisjoint P R \<Longrightarrow> R \<noteq> P"
using polygonDisjointSame by blast
lemma polygonDisjointSym: "pointList Ll\<Longrightarrow> P=cyclePath Ll\<Longrightarrow> polygon P\<Longrightarrow> pointList Lr\<Longrightarrow>
  R=cyclePath Lr\<Longrightarrow> polygon R \<Longrightarrow> polygonDisjoint P R = polygonDisjoint R P"
  apply (safe, simp add: polygonDisjoint_def)
  apply (simp add: cyclePathIntersect_def cyclePathSegments intersectSym1 lineCyclePathIntersEq
    polygonInPolygonSym)
by (simp add: cyclePathIntersect_def cyclePathSegments intersectSym1 lineCyclePathIntersEq
  polygonDisjoint_def polygonInPolygonSym)

definition polygonsDisjoint :: "(point2d list) list \<Rightarrow> bool" where
  "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> polygonsDisjoint PL \<equiv> \<forall> i j. (i\<noteq>j \<and>
    i < length PL \<and> j < length PL) \<longrightarrow>  polygonDisjoint (cyclePath (PL!i)) (cyclePath (PL!j))"

lemma polygonsDisjointSimp [simp]: "pointLists [A,B] \<Longrightarrow> polygonList [A,B] \<Longrightarrow>
  polygonDisjoint (cyclePath A) (cyclePath B) = polygonsDisjoint [A,B]"
  apply (safe) defer apply (simp add: polygonsDisjoint_def)
  apply (erule_tac x=0 in allE, erule_tac x=1 in allE, simp)
  apply (simp add: polygonsDisjoint_def, (rule allI)+, safe)
  apply (case_tac "i=0", subgoal_tac "j=1", simp+, subgoal_tac "j=0", auto)
by (meson pointListsSimp polygonDisjointSym polygonListSimp1)
(*alle elemente sind disjoint, außer zu sich selbst*)
lemma polygonsDisjointSimp1: "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow>
  i < length PL \<Longrightarrow> j < length PL \<Longrightarrow> i \<noteq> j \<Longrightarrow> polygonsDisjoint PL \<Longrightarrow>
  polygonDisjoint (cyclePath (PL!i)) (cyclePath (PL!j))"
by (auto simp add: polygonsDisjoint_def)
(*kein Polygon kommt doppet vor*)
lemma disjointPolygonListDistinct : "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow> i < length PL \<Longrightarrow>
  j < length PL \<Longrightarrow> i \<noteq> j \<Longrightarrow> polygonsDisjoint PL \<Longrightarrow> distinct PL"
  apply (insert polygonDisjointSame1)
by(metis distinct_conv_nth pointListsSimp2 polygonListSimp polygonsDisjointSimp1)

(*disjointe polygonenListe, hat keine schnittpunkte*)
lemma polygonDisjoinPathsIntersect [simp]: "pointLists PL \<Longrightarrow> polygonList PL \<Longrightarrow>
  polygonsDisjoint PL \<Longrightarrow> \<not>cyclePathsIntersect PL"
  apply (auto simp add: polygonsDisjoint_def cyclePathsIntersect_def)
  apply (erule_tac x=i in allE, erule_tac x=j in allE, simp add: polygonDisjoint_def)
by (cut_tac Ll="PL ! i" and P="cyclePath (PL ! i)" and Lr="PL ! j" and R="cyclePath (PL ! j)"
    in polygonDisjoint_def, simp+)
*)

(*(*Punkt inside convex Polygon.*)
(*Testweise. überprüfe ob Punkt für alle segmente des Polygons rechts oder links gerichtet ist*)
(*wenn Punkt auf Kante liegt, zählt es nicht.*)
definition pointInsideCPolygonACl :: "point2d list \<Rightarrow> point2d \<Rightarrow> bool" where
"pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygonACl P a \<equiv> \<forall> i j. 0 \<le> i \<and> j = i + 1 \<and> j < size P \<longrightarrow> signedArea (P!i) (P!j) a > 0"
definition pointInsideCPolygonCCl :: "point2d list \<Rightarrow> point2d \<Rightarrow> bool" where
"pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygonCCl P a \<equiv> pointInsideCPolygonACl (rev P) a"
(*irgndwo hier ist ein Denkfehler*)
theorem pointInsideCPolygonCClEq : "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow> \<not>collinearList L \<Longrightarrow>
  pointInsideCPolygonCCl P a = (\<forall> i j. 0 \<le> i \<and> j = i + 1 \<and> j < size P \<longrightarrow> signedArea (P!i) (P!j) a < 0)"
  apply (simp only: pointInsideCPolygonCCl_def)
  apply (cut_tac P="rev P" and a=a and L="hd L # rev (tl L)" in pointInsideCPolygonACl_def, simp)
    apply (metis revCycleEq revCycle_def)
    apply (simp add: cPolygonRev)
  apply (simp, rule iffI, safe)
  apply (thin_tac "pointInsideCPolygonACl (rev (cyclePath L)) a \<equiv>
         \<forall>i<length L. 0 < signedArea a (rev (cyclePath L) ! i) (rev (cyclePath L) ! Suc i)")
  apply (erule_tac x="(length (cyclePath L) - 1) - i" in allE)
  apply (erule impE)
  apply (simp add: cyclePath_def)
sorry

definition pointInsideCPolygon :: "point2d list \<Rightarrow> point2d \<Rightarrow> bool" where
  "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygon P a \<equiv> pointInsideCPolygonCCl P a \<or> pointInsideCPolygonACl P a"
lemma pointInsideCPolygonRev1: "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygon (rev P) a \<equiv> pointInsideCPolygonCCl (rev P) a \<or> pointInsideCPolygonACl (rev P) a"
  apply (cut_tac P=P and L=L in cPolygonRev, assumption+)
  apply (cut_tac P="rev P" and L="hd L # rev (tl L)" and a=a in pointInsideCPolygon_def)
  apply (simp, simp add: cyclePath_def)
  apply (metis list.collapse list.size(3) not_less numeral_eq_Suc pointList_def rev.simps(2) zero_less_Suc)
  apply (simp)
by auto
theorem pointInsideCPolygonRev: "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygon P a = pointInsideCPolygon (rev P) a"
  apply (cut_tac P=P and L=L in cPolygonRev, assumption+)
  apply (simp add: pointInsideCPolygonRev1 pointInsideCPolygon_def, safe)
  apply (auto simp add: pointInsideCPolygonCCl_def)
sorry

lemma "pointList L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow>
  pointInsideCPolygon P a \<Longrightarrow> pointInPolygon P a" thm cPolygonIsPolygon
  apply (cut_tac L=L and P=P in cPolygonIsPolygon, assumption+)
oops

(*Segment inside convex Polygon. Testweise*)
definition segmentInsideCPolygon :: "point2d list \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "segment A B \<Longrightarrow> pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> cPolygon P \<Longrightarrow>
  segmentInsideCPolygon P A B \<equiv> pointInsideCPolygon P A \<and> pointInsideCPolygon P B"

(*wenn ein punkt einer Strecke inside convex Polygon und ein Punkt einer Strecke outside, dann gibt es eine intersection*)
lemma twoPointPolygonInter : "pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow>  \<not>collinearList L \<Longrightarrow> cPolygon P
  \<Longrightarrow> pointInsideCPolygon P a \<Longrightarrow> \<not>pointInsideCPolygon P b \<Longrightarrow> lineCyclePathInters P a b"
  apply (subgoal_tac "segment a b")
    apply (subst lineCyclePathIntersEq, simp)
    apply (simp add: pointInsideCPolygon_def pointInsideCPolygonACl_def)
    apply (simp add: pointInsideCPolygonCClEq, safe)
    apply (erule_tac x="ia" in allE, simp)
    apply (rule_tac x="ia" in exI, simp)
    apply (subgoal_tac "segment (cyclePath L ! ia) (cyclePath L ! Suc ia)")
sorry
(*wenn segment inside convex Polygon, dann schneidet das segment das Polygon nicht*)
lemma "segment A B \<Longrightarrow> pointList L \<Longrightarrow> P = cyclePath L \<Longrightarrow> \<not>collinearList L \<Longrightarrow> cPolygon P \<Longrightarrow>
  segmentInsideCPolygon P A B \<Longrightarrow> \<not>lineCyclePathInters P A B"
oops*)

(*alte Definition*)
end