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

section \<open>Quantum Prisoner's Dilemma\<close>

theory Quantum_Prisoners_Dilemma
imports
  More_Tensor
  Measurement
  Basics
begin

text \<open>
In the 2-parameter strategic space of Eisert, Wilkens and Lewenstein [EWL], Prisoner's Dilemma
ceases to pose a dilemma if quantum strategies are allowed for. Indeed, Alice and Bob both choosing
to defect is no longer a Nash equilibrium. However, a new Nash equilibrium appears which is at the
same time Pareto optimal. Moreover, there exists a quantum strategy which always gives reward if
played against any classical strategy.
Below the parameter @{text "\<gamma>"} can be seen as a measure of the game's entanglement. The game behaves
classically if @{text "\<gamma>"} = 0, and for the maximally entangled case (@{text "\<gamma>"} = 2*$\pi$) the dilemma disappears
as pointed out above.
\<close>

subsection \<open>The Set-Up\<close>

locale prisoner =
  fixes \<gamma>:: "real"
  assumes "\<gamma> \<le> pi/2" and "\<gamma> \<ge> 0"

abbreviation (in prisoner) J :: "complex Matrix.mat" where
"J \<equiv> mat_of_cols_list 4  [[cos(\<gamma>/2), 0, 0, \<i>*sin(\<gamma>/2)],
                          [0, cos(\<gamma>/2), -\<i>*sin(\<gamma>/2), 0],
                          [0, -\<i>*sin(\<gamma>/2), cos(\<gamma>/2), 0],
                          [\<i>*sin(\<gamma>/2), 0, 0, cos(\<gamma>/2)]]"

abbreviation (in prisoner) \<psi>\<^sub>1 :: "complex Matrix.mat" where
"\<psi>\<^sub>1 \<equiv> mat_of_cols_list 4 [[cos(\<gamma>/2), 0, 0, \<i>*sin(\<gamma>/2)]]"

lemma (in prisoner) psi_one:
  shows "J * |unit_vec 4 0\<rangle> = \<psi>\<^sub>1"
proof
  fix i j assume a0:"i < dim_row \<psi>\<^sub>1" and a1:"j < dim_col \<psi>\<^sub>1"
  then have "(J * |unit_vec 4 0\<rangle>) $$ (i,j) = (\<Sum>k<4. (J $$ (i,k)) * ( |unit_vec 4 0\<rangle> $$ (k,j)))"
    using mat_of_cols_list_def ket_vec_def by auto
  also have "... = (\<Sum>k\<in>{0,1,2,3}. (J $$ (i,k)) * ( |unit_vec 4 0\<rangle> $$ (k,j)))"
    using set_4 atLeast0LessThan by simp
  also have "... = \<psi>\<^sub>1 $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j=0"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def by auto
  qed
  finally show "(J * |unit_vec 4 0\<rangle>) $$ (i,j) = \<psi>\<^sub>1 $$ (i,j)" by simp
next
  show  "dim_row (J * |unit_vec 4 0\<rangle>) = dim_row \<psi>\<^sub>1"
    using mat_of_cols_list_def by simp
next
  show  "dim_col (J*|unit_vec 4 0\<rangle>) = dim_col \<psi>\<^sub>1"
    using mat_of_cols_list_def by (simp add: ket_vec_def)
qed

locale strategic_space_2p = prisoner +
  fixes \<theta>\<^sub>A:: "real"
    and \<phi>\<^sub>A:: "real"
    and \<theta>\<^sub>B:: "real"
    and \<phi>\<^sub>B:: "real"
  assumes "0 \<le> \<theta>\<^sub>A \<and> \<theta>\<^sub>A \<le> pi"
      and "0 \<le> \<phi>\<^sub>A \<and> \<phi>\<^sub>A \<le> pi/2"
      and "0 \<le> \<theta>\<^sub>B \<and> \<theta>\<^sub>B \<le> pi"
      and "0 \<le> \<phi>\<^sub>B \<and> \<phi>\<^sub>B \<le> pi/2"

abbreviation (in strategic_space_2p) U\<^sub>A :: "complex Matrix.mat" where
"U\<^sub>A \<equiv> mat_of_cols_list 2 [[exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2), -sin(\<theta>\<^sub>A/2)],
                           [sin(\<theta>\<^sub>A/2), exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2)]]"

abbreviation (in strategic_space_2p) U\<^sub>B :: "complex Matrix.mat" where
"U\<^sub>B \<equiv> mat_of_cols_list 2 [[exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2), -sin(\<theta>\<^sub>B/2)],
                           [sin(\<theta>\<^sub>B/2), exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2)]]"

abbreviation (in strategic_space_2p) \<psi>\<^sub>2 :: "complex Matrix.mat" where
"\<psi>\<^sub>2 \<equiv>
mat_of_cols_list 4 [[exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2),
                     exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2),
                     -sin(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2),
                     sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2)]]"

abbreviation (in strategic_space_2p) U\<^sub>A\<^sub>B :: "complex Matrix.mat" where
"U\<^sub>A\<^sub>B \<equiv>
mat_of_cols_list 4 [[exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2), exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2),
                            -sin(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2), -sin(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2)],
                    [exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2), exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2),
                            -sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2), -sin(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2)],
                    [sin(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2), -sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2),
                            exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp (\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2), exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2)],
                    [sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2), sin(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2),
                            exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2), exp (-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2)]]"

lemma (in strategic_space_2p) U\<^sub>A_tensor_U\<^sub>B:
  shows "(U\<^sub>A \<Otimes> U\<^sub>B) = U\<^sub>A\<^sub>B"
proof
  fix i j assume a0: "i<dim_row U\<^sub>A\<^sub>B" and a1: "j<dim_col U\<^sub>A\<^sub>B"
  then have "i\<in>{0,1,2,3} \<and> j\<in>{0,1,2,3}"
    using mat_of_cols_list_def by auto
  then show "(U\<^sub>A \<Otimes> U\<^sub>B) $$ (i,j) = U\<^sub>A\<^sub>B $$ (i,j)"
    using mat_of_cols_list_def by auto
next
  show "dim_row (U\<^sub>A \<Otimes> U\<^sub>B) = dim_row U\<^sub>A\<^sub>B"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>A \<Otimes> U\<^sub>B) = dim_col U\<^sub>A\<^sub>B"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) psi_two:
  shows "(U\<^sub>A \<Otimes> U\<^sub>B) * \<psi>\<^sub>1 = \<psi>\<^sub>2"
proof
  fix i j
  assume a0:"i < dim_row \<psi>\<^sub>2" and a1:"j < dim_col \<psi>\<^sub>2"
  then show "((U\<^sub>A \<Otimes> U\<^sub>B) * \<psi>\<^sub>1) $$ (i,j) = \<psi>\<^sub>2 $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j=0"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def U\<^sub>A_tensor_U\<^sub>B set_4 by auto
  qed
next
  show "dim_row ((U\<^sub>A \<Otimes> U\<^sub>B)*\<psi>\<^sub>1) = dim_row \<psi>\<^sub>2"
    using mat_of_cols_list_def by simp
next
  show "dim_col ((U\<^sub>A \<Otimes> U\<^sub>B)*\<psi>\<^sub>1) = dim_col \<psi>\<^sub>2"
    using mat_of_cols_list_def by simp
qed

abbreviation (in prisoner) J_cnj :: "complex Matrix.mat" where
"J_cnj \<equiv> mat_of_cols_list 4 [[cos(\<gamma>/2), 0, 0, -\<i>*sin(\<gamma>/2)],
                             [0, cos(\<gamma>/2), \<i>*sin(\<gamma>/2), 0],
                             [0, \<i>*sin(\<gamma>/2), cos(\<gamma>/2), 0],
                             [-\<i>*sin(\<gamma>/2), 0, 0, cos(\<gamma>/2)]]"

lemma (in prisoner) hermite_cnj_of_J [simp]:
  shows "J\<^sup>\<dagger> = J_cnj"
proof
  fix i j assume a0:"i < dim_row J_cnj" and a1:"j < dim_col J_cnj"
  then show "J\<^sup>\<dagger> $$ (i,j) = J_cnj $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j\<in>{0,1,2,3}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def dagger_def by auto
  qed
next
  show "dim_row (J\<^sup>\<dagger>) = dim_row J_cnj"
    using mat_of_cols_list_def by simp
next
  show "dim_col (J\<^sup>\<dagger>) = dim_col J_cnj"
    using mat_of_cols_list_def by simp
qed

abbreviation (in strategic_space_2p) \<psi>\<^sub>f :: "complex Matrix.mat" where
"\<psi>\<^sub>f \<equiv> mat_of_cols_list 4 [[
cos(\<gamma>/2) * (exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2))
+ (-\<i>*sin(\<gamma>/2)) * (sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2)),

cos(\<gamma>/2) * (exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2))
+ (\<i>*sin(\<gamma>/2)) * (-sin(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2)),

(\<i>*sin(\<gamma>/2)) * (exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * -sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2))
+ cos(\<gamma>/2) * (-sin(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2)),

(-\<i>*sin(\<gamma>/2)) * (exp(\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2))
+ cos(\<gamma>/2) * (sin(\<theta>\<^sub>A/2) * sin(\<theta>\<^sub>B/2) * cos(\<gamma>/2) + exp(-\<i>*\<phi>\<^sub>A)*cos(\<theta>\<^sub>A/2) * exp(-\<i>*\<phi>\<^sub>B)*cos(\<theta>\<^sub>B/2) * \<i>*sin(\<gamma>/2))
]]"

lemma (in strategic_space_2p) psi_f:
  shows "(J\<^sup>\<dagger>) * \<psi>\<^sub>2 = \<psi>\<^sub>f"
proof
  fix i j assume a0:"i < dim_row \<psi>\<^sub>f" and a1:"j < dim_col \<psi>\<^sub>f"
  then show "((J\<^sup>\<dagger>) * \<psi>\<^sub>2) $$ (i,j) = \<psi>\<^sub>f $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j=0"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def set_4 hermite_cnj_of_J by auto
  qed
next
  show "dim_row ((J\<^sup>\<dagger>) * \<psi>\<^sub>2) = dim_row \<psi>\<^sub>f"
    using mat_of_cols_list_def by simp
next
  show "dim_col ((J\<^sup>\<dagger>) * \<psi>\<^sub>2) = dim_col \<psi>\<^sub>f"
    using mat_of_cols_list_def by simp
qed

lemma (in prisoner) unit_vec_4_0_ket_is_state:
  shows "state 2 |unit_vec 4 0\<rangle>"
  using state_def cpx_vec_length_def ket_vec_def unit_vec_def by (auto simp add: set_4)

lemma cos_sin_squared_add_cpx:
  "complex_of_real (cos (\<gamma>/2)) * complex_of_real (cos (\<gamma>/2)) -
   \<i>*complex_of_real (sin (\<gamma>/2)) * (\<i>*complex_of_real (sin (\<gamma>/2))) = 1"
    apply (auto simp add: algebra_simps)
    by (metis of_real_add of_real_hom.hom_one of_real_mult sin_cos_squared_add3)

lemma sin_cos_squared_add_cpx:
  "\<i>*complex_of_real (sin (\<gamma>/2)) * (\<i>*complex_of_real (sin (\<gamma>/2))) -
   complex_of_real (cos (\<gamma>/2)) * complex_of_real (cos (\<gamma>/2)) = -1"
    apply (auto simp add: algebra_simps)
    by (metis of_real_add of_real_hom.hom_one of_real_mult sin_cos_squared_add3)

lemma (in prisoner) J_cnj_times_J:
  shows "J\<^sup>\<dagger> * J = 1\<^sub>m 4"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 4)" and a1:"j < dim_col (1\<^sub>m 4)"
  then show "(J\<^sup>\<dagger> * J) $$ (i,j) = 1\<^sub>m 4 $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j\<in>{0,1,2,3}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def hermite_cnj_of_J set_4 cos_sin_squared_add_cpx by auto
  qed
next
  show "dim_row (J\<^sup>\<dagger> * J) = dim_row (1\<^sub>m 4)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (J\<^sup>\<dagger> * J) = dim_col (1\<^sub>m 4)"
    using mat_of_cols_list_def by simp
qed

lemma (in prisoner) J_times_J_cnj:
  shows "J * (J\<^sup>\<dagger>) = 1\<^sub>m 4"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 4)" and a1:"j < dim_col (1\<^sub>m 4)"
  then show "(J * (J\<^sup>\<dagger>)) $$ (i,j) = 1\<^sub>m 4 $$ (i,j)"
  proof-
    have "i\<in>{0,1,2,3} \<and> j\<in>{0,1,2,3}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def hermite_cnj_of_J set_4 cos_sin_squared_add_cpx by auto
  qed
next
  show "dim_row (J * (J\<^sup>\<dagger>)) = dim_row (1\<^sub>m 4)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (J * (J\<^sup>\<dagger>)) = dim_col (1\<^sub>m 4)"
    using mat_of_cols_list_def by simp
qed

lemma (in prisoner) J_is_gate:
  shows "gate 2 J"
proof
  show "dim_row J = 2\<^sup>2"
    using mat_of_cols_list_def by simp
  moreover show "square_mat J"
    using mat_of_cols_list_def by simp
  ultimately show "unitary J"
    using mat_of_cols_list_def unitary_def J_cnj_times_J J_times_J_cnj by auto
qed

lemma (in strategic_space_2p) psi_one_is_state:
  shows "state 2 \<psi>\<^sub>1"
proof-
  have "state 2 (J * |unit_vec 4 0\<rangle>)"
    using unit_vec_4_0_ket_is_state J_is_gate by auto
  then show ?thesis
    using psi_one by simp
qed

abbreviation (in strategic_space_2p) U\<^sub>A_cnj :: "complex Matrix.mat" where
"U\<^sub>A_cnj \<equiv> mat_of_cols_list 2 [[(exp(-\<i>*\<phi>\<^sub>A))*cos(\<theta>\<^sub>A/2), sin(\<theta>\<^sub>A/2)],
                              [-sin(\<theta>\<^sub>A/2), (exp (\<i>*\<phi>\<^sub>A))*cos(\<theta>\<^sub>A/2)]]"

abbreviation (in strategic_space_2p) U\<^sub>B_cnj :: "complex Matrix.mat" where
"U\<^sub>B_cnj \<equiv> mat_of_cols_list 2 [[(exp(-\<i>*\<phi>\<^sub>B))*cos(\<theta>\<^sub>B/2), sin(\<theta>\<^sub>B/2)],
                              [-sin(\<theta>\<^sub>B/2), (exp(\<i>*\<phi>\<^sub>B))*cos(\<theta>\<^sub>B/2)]]"

lemma (in strategic_space_2p) hermite_cnj_of_U\<^sub>A:
  shows "U\<^sub>A\<^sup>\<dagger> = U\<^sub>A_cnj"
proof
  fix i j assume a0:"i < dim_row U\<^sub>A_cnj" and a1:"j < dim_col U\<^sub>A_cnj"
  then show "U\<^sub>A\<^sup>\<dagger> $$ (i,j) = U\<^sub>A_cnj $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def dagger_def exp_of_real_cnj exp_of_real_cnj2 by auto
  qed
next
  show "dim_row (U\<^sub>A\<^sup>\<dagger>) = dim_row U\<^sub>A_cnj"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>A\<^sup>\<dagger>) = dim_col U\<^sub>A_cnj"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) hermite_cnj_of_U\<^sub>B:
  shows "U\<^sub>B\<^sup>\<dagger> = U\<^sub>B_cnj"
proof
  fix i j assume a0:"i < dim_row U\<^sub>B_cnj" and a1:"j < dim_col U\<^sub>B_cnj"
  then show "U\<^sub>B\<^sup>\<dagger> $$ (i,j) = U\<^sub>B_cnj $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def dagger_def exp_of_real_cnj exp_of_real_cnj2 by auto
  qed
next
  show "dim_row (U\<^sub>B\<^sup>\<dagger>) = dim_row U\<^sub>B_cnj"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>B\<^sup>\<dagger>) = dim_col U\<^sub>B_cnj"
    using mat_of_cols_list_def by simp
qed

lemma exp_sin_cos_squared_add:
  fixes x y :: real
  shows "exp (- (\<i> * x)) * cos (y) * (exp (\<i> * x) * cos (y)) + sin(y) * sin(y) = 1"
proof-
  have "exp (- (\<i> * x)) * cos (y) * (exp (\<i> * x) * cos (y)) = cos(y) * cos(y)"
    using exp_minus_inverse by (auto simp add: algebra_simps)
  then show ?thesis
    by (metis of_real_add of_real_hom.hom_one sin_cos_squared_add3)
qed

lemma (in strategic_space_2p) U\<^sub>A_cnj_times_U\<^sub>A:
  shows "U\<^sub>A\<^sup>\<dagger> * U\<^sub>A = 1\<^sub>m 2"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 2)" and a1:"j < dim_col (1\<^sub>m 2)"
  then show "(U\<^sub>A\<^sup>\<dagger> * U\<^sub>A) $$ (i,j) = 1\<^sub>m 2 $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def cos_sin_squared_add_cpx hermite_cnj_of_U\<^sub>A exp_sin_cos_squared_add[of "\<phi>\<^sub>A" "\<theta>\<^sub>A / 2"]
      by (auto simp add: set_2 algebra_simps)
  qed
next
  show "dim_row (U\<^sub>A\<^sup>\<dagger> * U\<^sub>A) = dim_row (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>A\<^sup>\<dagger> * U\<^sub>A) = dim_col (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) U\<^sub>A_times_U\<^sub>A_cnj:
  shows "U\<^sub>A * (U\<^sub>A\<^sup>\<dagger>) = 1\<^sub>m 2"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 2)" and a1:"j < dim_col (1\<^sub>m 2)"
  then show "(U\<^sub>A * (U\<^sub>A\<^sup>\<dagger>)) $$ (i,j) = 1\<^sub>m 2 $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def cos_sin_squared_add_cpx hermite_cnj_of_U\<^sub>A exp_sin_cos_squared_add[of "\<phi>\<^sub>A" "\<theta>\<^sub>A / 2"]
      by (auto simp add: set_2 algebra_simps)
  qed
next
  show "dim_row (U\<^sub>A * (U\<^sub>A\<^sup>\<dagger>)) = dim_row (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>A * (U\<^sub>A\<^sup>\<dagger>)) = dim_col (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) U\<^sub>B_cnj_times_U\<^sub>B:
  shows "U\<^sub>B\<^sup>\<dagger> * U\<^sub>B = 1\<^sub>m 2"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 2)" and a1:"j < dim_col (1\<^sub>m 2)"
  then show "(U\<^sub>B\<^sup>\<dagger> * U\<^sub>B) $$ (i,j) = 1\<^sub>m 2 $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def cos_sin_squared_add_cpx hermite_cnj_of_U\<^sub>B exp_sin_cos_squared_add[of "\<phi>\<^sub>B" "\<theta>\<^sub>B / 2"]
      by (auto simp add: set_2 algebra_simps)
  qed
next
  show "dim_row (U\<^sub>B\<^sup>\<dagger> * U\<^sub>B) = dim_row (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>B\<^sup>\<dagger> * U\<^sub>B) = dim_col (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) U\<^sub>B_times_U\<^sub>B_cnj:
  shows "U\<^sub>B * (U\<^sub>B\<^sup>\<dagger>) = 1\<^sub>m 2"
proof
  fix i j assume a0:"i < dim_row (1\<^sub>m 2)" and a1:"j < dim_col (1\<^sub>m 2)"
  then show "(U\<^sub>B * (U\<^sub>B\<^sup>\<dagger>)) $$ (i,j) = 1\<^sub>m 2 $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def cos_sin_squared_add_cpx hermite_cnj_of_U\<^sub>B exp_sin_cos_squared_add[of "\<phi>\<^sub>B" "\<theta>\<^sub>B / 2"]
      by (auto simp add: set_2 algebra_simps)
  qed
next
  show "dim_row (U\<^sub>B * (U\<^sub>B\<^sup>\<dagger>)) = dim_row (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
next
  show "dim_col (U\<^sub>B * (U\<^sub>B\<^sup>\<dagger>)) = dim_col (1\<^sub>m 2)"
    using mat_of_cols_list_def by simp
qed

lemma (in strategic_space_2p) U\<^sub>A\<^sub>_is_gate:
  shows "gate 1 U\<^sub>A"
proof
  show "dim_row U\<^sub>A = 2^1"
    using mat_of_cols_list_def by simp
  moreover show "square_mat U\<^sub>A"
    using mat_of_cols_list_def by simp
  ultimately show "unitary U\<^sub>A"
    using mat_of_cols_list_def unitary_def U\<^sub>A_cnj_times_U\<^sub>A U\<^sub>A_times_U\<^sub>A_cnj by auto
qed

lemma (in strategic_space_2p) U\<^sub>B_is_gate:
  shows "gate 1 U\<^sub>B"
proof
  show "dim_row U\<^sub>B = 2^1"
    using mat_of_cols_list_def by simp
  moreover show "square_mat U\<^sub>B"
    using mat_of_cols_list_def by simp
  ultimately show "unitary U\<^sub>B"
    using mat_of_cols_list_def unitary_def U\<^sub>B_cnj_times_U\<^sub>B U\<^sub>B_times_U\<^sub>B_cnj by auto
qed

lemma (in strategic_space_2p) U\<^sub>A\<^sub>B_is_gate:
  shows "gate 2 (U\<^sub>A \<Otimes> U\<^sub>B)"
proof-
  have "gate (1+1) (U\<^sub>A \<Otimes> U\<^sub>B)"
    using U\<^sub>A\<^sub>_is_gate U\<^sub>B_is_gate tensor_gate[of "1" "U\<^sub>A" "1" "U\<^sub>B"] by auto
  then show ?thesis
    by (auto simp add: numeral_2_eq_2)
qed

lemma (in strategic_space_2p) psi_two_is_state:
  shows "state 2 \<psi>\<^sub>2"
proof-
  have "state 2 ((U\<^sub>A \<Otimes> U\<^sub>B) * \<psi>\<^sub>1)"
    using psi_one_is_state U\<^sub>A\<^sub>B_is_gate by auto
  then show ?thesis
    using psi_two by simp
qed

lemma (in strategic_space_2p) J_cnj_is_gate:
  shows "gate 2 (J\<^sup>\<dagger>)"
proof
  show "dim_row (J\<^sup>\<dagger>) = 2\<^sup>2"
    using mat_of_cols_list_def by simp
  moreover show "square_mat (J\<^sup>\<dagger>)"
    using mat_of_cols_list_def by simp
  moreover have "(J\<^sup>\<dagger>)\<^sup>\<dagger> = J"
    using dagger_of_dagger_is_id by auto
  ultimately show "unitary (J\<^sup>\<dagger>)"
    using mat_of_cols_list_def unitary_def J_cnj_times_J J_times_J_cnj by auto
qed

lemma (in strategic_space_2p) psi_f_is_state:
  shows "state 2 \<psi>\<^sub>f"
proof-
  have "state 2 ((J\<^sup>\<dagger>) * \<psi>\<^sub>2)"
    using psi_two_is_state J_cnj_is_gate by auto
  then show ?thesis
    using psi_f by simp
qed

(* equation (1) in the paper *)
lemma (in strategic_space_2p) equation_one:
  shows "(J\<^sup>\<dagger>) * ((U\<^sub>A \<Otimes> U\<^sub>B) * (J * |unit_vec 4 0\<rangle>)) = \<psi>\<^sub>f"
  using psi_one psi_two psi_f by auto

abbreviation (in strategic_space_2p) prob00 :: "complex Matrix.mat \<Rightarrow> real" where
"prob00 v \<equiv> if state 2 v then (cmod (v $$ (0,0)))\<^sup>2 else undefined"

abbreviation (in strategic_space_2p) prob01 :: "complex Matrix.mat \<Rightarrow> real" where
"prob01 v \<equiv> if state 2 v then (cmod (v $$ (1,0)))\<^sup>2 else undefined"

abbreviation (in strategic_space_2p) prob10 :: "complex Matrix.mat \<Rightarrow> real" where
"prob10 v \<equiv> if state 2 v then (cmod (v $$ (2,0)))\<^sup>2 else undefined"

abbreviation (in strategic_space_2p) prob11 :: "complex Matrix.mat \<Rightarrow> real" where
"prob11 v \<equiv> if state 2 v then (cmod (v $$ (3,0)))\<^sup>2 else undefined"

definition (in strategic_space_2p) alice_payoff :: "real" where
"alice_payoff \<equiv> 3 * (prob00 \<psi>\<^sub>f) + 1 * (prob11 \<psi>\<^sub>f) + 0 * (prob01 \<psi>\<^sub>f) + 5 * (prob10 \<psi>\<^sub>f)"

definition (in strategic_space_2p) bob_payoff :: "real" where
"bob_payoff \<equiv> 3 * (prob00 \<psi>\<^sub>f) + 1 * (prob11 \<psi>\<^sub>f) + 5 * (prob01 \<psi>\<^sub>f) + 0 * (prob10 \<psi>\<^sub>f)"

definition (in strategic_space_2p) is_nash_eq :: "bool" where
"is_nash_eq \<equiv>
(\<forall>tA pA. strategic_space_2p \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<longrightarrow>
    alice_payoff \<ge> strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B)
\<and>
(\<forall>tB pB. strategic_space_2p \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<longrightarrow>
    bob_payoff \<ge> strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB)"

definition (in strategic_space_2p) is_pareto_opt :: "bool" where
"is_pareto_opt \<equiv> \<forall>tA pA tB pB. strategic_space_2p \<gamma> tA pA tB pB \<longrightarrow>
((strategic_space_2p.alice_payoff \<gamma> tA pA tB pB > alice_payoff \<longrightarrow>
  strategic_space_2p.bob_payoff \<gamma> tA pA tB pB < bob_payoff) \<and>
 (strategic_space_2p.bob_payoff \<gamma> tA pA tB pB > bob_payoff \<longrightarrow>
  strategic_space_2p.alice_payoff \<gamma> tA pA tB pB < alice_payoff))"

lemma (in strategic_space_2p) sum_of_prob:
  fixes v :: "complex Matrix.mat"
  assumes "state 2 v"
  shows "(prob00 v) + (prob11 v) + (prob01 v) + (prob10 v) = 1"
proof-
  have "(prob00 v) + (prob11 v) + (prob01 v) + (prob10 v) =
        (cmod (v $$ (0,0)))\<^sup>2 + (cmod (v $$ (1,0)))\<^sup>2 + (cmod (v $$ (2,0)))\<^sup>2 + (cmod (v $$ (3,0)))\<^sup>2"
    using assms by auto
  then show ?thesis
    using state_def assms cpx_vec_length_def by (auto simp add: set_4)
qed

lemma (in strategic_space_2p) sum_payoff_le_6:
  fixes tA pA tB pB :: real
  shows "alice_payoff + bob_payoff \<le> 6"
proof-
  have "alice_payoff + bob_payoff = 6 * (prob00 \<psi>\<^sub>f) + 2 * (prob11 \<psi>\<^sub>f) + 5 * (prob01 \<psi>\<^sub>f) + 5 * (prob10 \<psi>\<^sub>f)"
    using alice_payoff_def bob_payoff_def psi_f_is_state by auto
  then have "alice_payoff + bob_payoff \<le> 6 * ((prob00 \<psi>\<^sub>f) + (prob11 \<psi>\<^sub>f) + (prob01 \<psi>\<^sub>f) + (prob10 \<psi>\<^sub>f))"
    using psi_f_is_state by (auto simp add: algebra_simps)
  moreover have "(prob00 \<psi>\<^sub>f) + (prob11 \<psi>\<^sub>f) + (prob01 \<psi>\<^sub>f) + (prob10 \<psi>\<^sub>f) = 1"
    using sum_of_prob[of "\<psi>\<^sub>f"] psi_f_is_state by auto
  ultimately show ?thesis
    by auto
qed

lemma (in strategic_space_2p) coop_is_pareto_opt:
  assumes "alice_payoff = 3 \<and> bob_payoff = 3"
  shows "is_pareto_opt"
  using is_pareto_opt_def strategic_space_2p.sum_payoff_le_6 assms by fastforce

subsection \<open>The Separable Case\<close>

lemma (in strategic_space_2p) separable_case_CC: (* both player cooperate *)
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> alice_payoff = 3 \<and> bob_payoff = 3"
  using alice_payoff_def bob_payoff_def cos_sin_squared_add_cpx psi_f_is_state by auto

lemma (in strategic_space_2p) separable_case_DD: (* both player defect *)
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> alice_payoff = 1 \<and> bob_payoff = 1"
  using alice_payoff_def bob_payoff_def cos_sin_squared_add_cpx psi_f_is_state by auto

lemma (in strategic_space_2p) separable_case_DC: (* Alice defects, and Bob cooperates *)
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> alice_payoff = 5 \<and> bob_payoff = 0"
  using alice_payoff_def bob_payoff_def sin_cos_squared_add_cpx psi_f_is_state by auto

lemma (in strategic_space_2p) separable_alice_payoff_D\<^sub>B:
(* Alice's payoff in the separable case given that Bob defects *)
  assumes "\<gamma> = 0" and "\<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi"
  shows "alice_payoff \<le> 1"
  using alice_payoff_def assms sin_squared_le_one psi_f_is_state by auto

lemma (in strategic_space_2p) separable_bob_payoff_D\<^sub>A:
(* Bob's payoff in the separable case given that Alice defects *)
  assumes "\<gamma> = 0" and "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi"
  shows "bob_payoff \<le> 1"
  using bob_payoff_def assms sin_squared_le_one psi_f_is_state by auto

lemma (in strategic_space_2p) separable_case_DD_alice_opt:
  assumes "\<gamma> = 0" and "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi"
  shows "\<And>tA pA. strategic_space_2p \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<longrightarrow> strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<le> alice_payoff"
proof
  fix tA pA assume "strategic_space_2p \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B"
  then show "strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<le> alice_payoff"
    using separable_case_DD strategic_space_2p.separable_alice_payoff_D\<^sub>B assms by auto
qed

lemma (in strategic_space_2p) separable_case_DD_bob_opt:
  assumes "\<gamma> = 0" and "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi"
  shows "\<And>tB pB. strategic_space_2p \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<longrightarrow> strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<le> bob_payoff"
proof
  fix tB pB assume "strategic_space_2p \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB"
  then show "strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<le> bob_payoff"
    using separable_case_DD strategic_space_2p.separable_bob_payoff_D\<^sub>A assms by auto
qed

lemma (in strategic_space_2p) separable_case_DD_is_nash_eq:
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> is_nash_eq"
  using is_nash_eq_def separable_case_DD_alice_opt separable_case_DD_bob_opt assms by auto

lemma (in strategic_space_2p) separable_case_CC_is_not_nash_eq:
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> \<not> is_nash_eq"
proof
  assume asm:"\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0"
  then have f0:"strategic_space_2p \<gamma> pi 0 \<theta>\<^sub>B \<phi>\<^sub>B"
    using strategic_space_2p_def strategic_space_2p_axioms_def prisoner_def asm by (simp add: assms)
  then have "strategic_space_2p.alice_payoff \<gamma> pi 0 \<theta>\<^sub>B \<phi>\<^sub>B = 5"
    using strategic_space_2p.separable_case_DC assms asm by blast
  moreover have "alice_payoff = 3"
    using separable_case_CC assms asm by blast
  ultimately have "strategic_space_2p \<gamma> pi 0 \<theta>\<^sub>B \<phi>\<^sub>B \<and> strategic_space_2p.alice_payoff \<gamma> pi 0 \<theta>\<^sub>B \<phi>\<^sub>B > alice_payoff"
    using f0 by simp
  then show "\<not>is_nash_eq"
    using is_nash_eq_def by fastforce
qed

lemma (in strategic_space_2p) separable_case_CC_is_pareto_optimal:
  assumes "\<gamma> = 0"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> is_pareto_opt"
  using coop_is_pareto_opt separable_case_CC assms by auto

subsection \<open>The Maximally Entangled Case\<close>

lemma exp_to_sin:
  fixes x:: real
  shows "exp (\<i> * x) - exp (-(\<i> * x)) = 2 * \<i> * (sin x)"
  using exp_of_real exp_of_real_inv by simp

lemma exp_to_cos:
  fixes x:: real
  shows "exp (\<i> * x) + exp (-(\<i> * x)) = 2 * (cos x)"
  using exp_of_real exp_of_real_inv by simp

lemma cmod_real_prod_squared:
  fixes x y:: real
  shows "(cmod (complex_of_real x * complex_of_real y))\<^sup>2 = x\<^sup>2 * y\<^sup>2"
  by (simp add: norm_mult power_mult_distrib)

lemma quantum_payoff_simp:
  fixes x y:: real
  shows "3 * (cmod (complex_of_real (sin x) * complex_of_real (cos y)))\<^sup>2 +
         (cmod (complex_of_real (cos x) * complex_of_real (cos y)))\<^sup>2 =
         2 * (sin x)\<^sup>2 * (cos y)\<^sup>2 + (cos y)\<^sup>2"
proof-
  have "3 * (sin x)\<^sup>2 * (cos y)\<^sup>2 + (cos x)\<^sup>2 * (cos y)\<^sup>2 =
        (2 * (sin x)\<^sup>2 * (cos y)\<^sup>2) + ((sin x)\<^sup>2 + (cos x)\<^sup>2) * (cos y)\<^sup>2"
    by (auto simp add: algebra_simps simp del: sin_cos_squared_add2)
  then show ?thesis
    by (simp add: cmod_real_prod_squared power_mult_distrib)
qed

lemma quantum_payoff_le_3:
  fixes x y:: real
  shows "2 * (sin x)\<^sup>2 * (cos y)\<^sup>2 + (cos y)\<^sup>2 \<le> 3"
proof-
  have "(sin x)\<^sup>2 * (cos y)\<^sup>2 \<le> 1" by (simp add: sin_squared_le_one cos_squared_le_one mult_le_one)
  then have "2 * (sin x)\<^sup>2 * (cos y)\<^sup>2 \<le> 2" by simp
  moreover have "(cos y)\<^sup>2 \<le> 1"
    using cos_squared_le_one[of "y"] by simp
  ultimately show ?thesis by simp
qed

lemma sqrt_two_squared_cpx: "complex_of_real (sqrt 2) * complex_of_real (sqrt 2) = 2"
  by (metis mult_2_right numeral_Bit0 of_real_mult of_real_numeral real_sqrt_four real_sqrt_mult)

lemma hidden_sqrt_two_squared_cpx: "complex_of_real (sqrt 2) * (complex_of_real (sqrt 2) * x) / 4 = x/2"
  using sqrt_two_squared_cpx by (auto simp add: algebra_simps)

lemma (in strategic_space_2p) max_entangled_DD:
(* both players defects in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> alice_payoff = 1 \<and> bob_payoff = 1"
  using alice_payoff_def bob_payoff_def cos_sin_squared_add_cpx psi_f_is_state
  by auto

lemma (in strategic_space_2p) max_entangled_QQ:
(* both players play the move Q in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> alice_payoff = 3 \<and> bob_payoff = 3"
  using alice_payoff_def bob_payoff_def sin_cos_squared_add_cpx exp_of_half_pi exp_of_minus_half_pi psi_f_is_state
  by auto

lemma (in strategic_space_2p) max_entangled_QD:
(* Alice plays the move Q, and Bob defects in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> alice_payoff = 5 \<and> bob_payoff = 0"
  using alice_payoff_def bob_payoff_def cos_sin_squared_add_cpx exp_of_half_pi exp_of_minus_half_pi
        psi_f_is_state sqrt_two_squared_cpx
  by (auto simp add: assms algebra_simps sin_45 cos_45)

lemma (in strategic_space_2p) max_entangled_alice_payoff_Q\<^sub>B:
(* Alice's payoff in the maximally entangled case given that Bob plays the move Q *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> alice_payoff \<le> 3"
proof
  assume asm:"\<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0"
  have "\<psi>\<^sub>f $$ (0,0) = -(sin \<phi>\<^sub>A) * (cos (\<theta>\<^sub>A/2))"
  proof-
    have "\<psi>\<^sub>f $$ (0,0) = \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>A/2)) * exp (\<i> * \<phi>\<^sub>A) +
                        \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>A/2)) * -exp (-(\<i> * \<phi>\<^sub>A))"
      using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi
      by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
    then have "\<psi>\<^sub>f $$ (0,0) = \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>A/2)) * (exp (\<i> * \<phi>\<^sub>A) - exp (-(\<i> * \<phi>\<^sub>A)))"
      by (auto simp add: algebra_simps)
    then have "\<psi>\<^sub>f $$ (0,0) = \<i> * (cos (\<theta>\<^sub>A/2)) * (1/2) * (exp (\<i> * \<phi>\<^sub>A) - exp (-(\<i> * \<phi>\<^sub>A)))"
      using sqrt_two_squared_cpx by (auto simp add: algebra_simps)
    then show ?thesis
      using exp_to_sin by (simp add: algebra_simps)
  qed
  moreover have "\<psi>\<^sub>f $$ (1,0) = sin (\<theta>\<^sub>A/2)"
    using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi sqrt_two_squared_cpx
    by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"])
  moreover have "\<psi>\<^sub>f $$ (2,0) = 0"
    using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi sqrt_two_squared_cpx
    by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (3,0) = (cos \<phi>\<^sub>A) * (cos (\<theta>\<^sub>A/2))"
  proof-
    have "\<psi>\<^sub>f $$ (3,0) = exp (\<i> * \<phi>\<^sub>A) * (cos (\<theta>\<^sub>A/2)) * (sqrt 2/2) * (sqrt 2/2) +
                        exp (- (\<i> * \<phi>\<^sub>A)) * (cos (\<theta>\<^sub>A/2)) * (sqrt 2/2) * (sqrt 2/2)"
      using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi
      by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
    then have "\<psi>\<^sub>f $$ (3,0) = (exp (\<i> * \<phi>\<^sub>A) + exp (-(\<i> * \<phi>\<^sub>A))) * (cos (\<theta>\<^sub>A/2)) * (sqrt 2/2) * (sqrt 2/2)"
      by (auto simp add: algebra_simps)
    then have "\<psi>\<^sub>f $$ (3,0) = (exp (\<i> * \<phi>\<^sub>A) + exp (-(\<i> * \<phi>\<^sub>A))) * (cos (\<theta>\<^sub>A/2)) * (1/2)"
      using sqrt_two_squared_cpx hidden_sqrt_two_squared_cpx by (auto simp add: algebra_simps)
    then show ?thesis
      using exp_to_cos by (simp add: algebra_simps)
  qed
  ultimately show "alice_payoff \<le> 3"
  using alice_payoff_def psi_f_is_state quantum_payoff_simp quantum_payoff_le_3
  by auto
qed

lemma (in strategic_space_2p) max_entangled_bob_payoff_Q\<^sub>A:
(* Bob's payoff in the maximally entangled case given that Alice plays the move Q *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<longrightarrow> bob_payoff \<le> 3"
proof
  assume asm:"\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0"
  have "\<psi>\<^sub>f $$ (0,0) = -(sin \<phi>\<^sub>B) * (cos (\<theta>\<^sub>B/2))"
  proof-
    have "\<psi>\<^sub>f $$ (0,0) = \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>B/2)) * exp (\<i> * \<phi>\<^sub>B) +
                        \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>B/2)) * -exp (-(\<i> * \<phi>\<^sub>B))"
      using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi
      by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
    then have "\<psi>\<^sub>f $$ (0,0) = \<i> * (sqrt 2/2) * (sqrt 2/2) * (cos (\<theta>\<^sub>B/2)) * (exp (\<i> * \<phi>\<^sub>B) - exp (-(\<i> * \<phi>\<^sub>B)))"
      by (auto simp add: algebra_simps)
    then have "\<psi>\<^sub>f $$ (0,0) = \<i> * (cos (\<theta>\<^sub>B/2)) * (1/2) * (exp (\<i> * \<phi>\<^sub>B) - exp (-(\<i> * \<phi>\<^sub>B)))"
      using sqrt_two_squared_cpx by (auto simp add: algebra_simps)
    then show ?thesis
      using exp_to_sin by (simp add: algebra_simps)
  qed
  moreover have "\<psi>\<^sub>f $$ (1,0) = 0"
    using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi sqrt_two_squared_cpx
    by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (2,0) = sin (\<theta>\<^sub>B/2)"
    using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi sqrt_two_squared_cpx
    by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (3,0) = (cos \<phi>\<^sub>B) * (cos (\<theta>\<^sub>B/2))"
  proof-
    have "\<psi>\<^sub>f $$ (3,0) = exp (\<i> * \<phi>\<^sub>B) * (cos (\<theta>\<^sub>B/2)) * (sqrt 2/2) * (sqrt 2/2) +
                        exp (- (\<i> * \<phi>\<^sub>B)) * (cos (\<theta>\<^sub>B/2)) * (sqrt 2/2) * (sqrt 2/2)"
      using mat_of_cols_list_def asm assms exp_of_half_pi exp_of_minus_half_pi
      by (auto simp add: sin_of_quarter_pi[of "\<gamma>"] cos_of_quarter_pi[of "\<gamma>"] algebra_simps)
    then have "\<psi>\<^sub>f $$ (3,0) = (exp (\<i> * \<phi>\<^sub>B) + exp (-(\<i> * \<phi>\<^sub>B))) * (cos (\<theta>\<^sub>B/2)) * (sqrt 2/2) * (sqrt 2/2)"
      by (auto simp add: algebra_simps)
    then have "\<psi>\<^sub>f $$ (3,0) = (exp (\<i> * \<phi>\<^sub>B) + exp (-(\<i> * \<phi>\<^sub>B))) * (cos (\<theta>\<^sub>B/2)) * (1/2)"
      using sqrt_two_squared_cpx hidden_sqrt_two_squared_cpx by (auto simp add: algebra_simps)
    then show ?thesis
      using exp_to_cos by (simp add: algebra_simps)
  qed
  ultimately show "bob_payoff \<le> 3"
  using bob_payoff_def psi_f_is_state quantum_payoff_simp quantum_payoff_le_3
  by auto
qed

lemma (in strategic_space_2p) max_entangled_DD_is_not_nash_eq:
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> \<not>is_nash_eq"
proof
  assume asm:"\<phi>\<^sub>A = 0 \<and> \<theta>\<^sub>A = pi \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi"
  then have f0:"strategic_space_2p \<gamma> 0 (pi/2) \<theta>\<^sub>B \<phi>\<^sub>B"
    using strategic_space_2p_def strategic_space_2p_axioms_def prisoner_def asm by (simp add: assms)
  then have "strategic_space_2p.alice_payoff \<gamma> 0 (pi/2) \<theta>\<^sub>B \<phi>\<^sub>B = 5"
    using strategic_space_2p.max_entangled_QD assms asm by blast
  moreover have "alice_payoff = 1"
    using max_entangled_DD assms asm by blast
  ultimately have "strategic_space_2p \<gamma> 0 (pi/2) \<theta>\<^sub>B \<phi>\<^sub>B \<and> strategic_space_2p.alice_payoff \<gamma> 0 (pi/2) \<theta>\<^sub>B \<phi>\<^sub>B > alice_payoff"
    using f0 by simp
  then show "\<not>is_nash_eq"
    using is_nash_eq_def by fastforce
qed

lemma (in strategic_space_2p) max_entangled_alice_opt:
  assumes "\<gamma> = pi/2" and "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0"
  shows "\<And>tA pA. strategic_space_2p \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<longrightarrow> strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<le> alice_payoff"
proof
  fix tA pA assume "strategic_space_2p \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B"
  then have "strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<le> 3"
    using strategic_space_2p.max_entangled_alice_payoff_Q\<^sub>B assms by blast
  moreover have "alice_payoff = 3"
    using max_entangled_QQ assms by blast
  ultimately show "strategic_space_2p.alice_payoff \<gamma> tA pA \<theta>\<^sub>B \<phi>\<^sub>B \<le> alice_payoff"
    by simp
qed

lemma (in strategic_space_2p) max_entangled_bob_opt:
  assumes "\<gamma> = pi/2" and "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0"
  shows "\<And>tB pB. strategic_space_2p \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<longrightarrow> strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<le> bob_payoff"
proof
  fix tB pB assume "strategic_space_2p \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB"
  then have "strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<le> 3"
    using strategic_space_2p.max_entangled_bob_payoff_Q\<^sub>A assms by blast
  moreover have "bob_payoff = 3"
    using max_entangled_QQ assms by blast
  ultimately show "strategic_space_2p.bob_payoff \<gamma> \<theta>\<^sub>A \<phi>\<^sub>A tB pB \<le> bob_payoff"
    by simp
qed

lemma (in strategic_space_2p) max_entangled_QQ_is_nash_eq:
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> is_nash_eq"
  using max_entangled_alice_opt max_entangled_bob_opt is_nash_eq_def assms by blast

lemma (in strategic_space_2p) max_entangled_QQ_is_pareto_optimal:
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = 0 \<and> \<phi>\<^sub>B = pi/2 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> is_pareto_opt"
  using coop_is_pareto_opt max_entangled_QQ assms by blast

subsection \<open>The Unfair Strategy Case\<close>

lemma half_sqrt_two_squared: "2 * (sqrt 2 / 2)\<^sup>2 = 1"
  by (auto simp add: power2_eq_square)

lemma (in strategic_space_2p) max_entangled_MD:
(* Alice plays the "miracle move", and Bob plays the classical defect move in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi \<longrightarrow> alice_payoff = 3 \<and> bob_payoff = 1/2"
proof
  assume asm:"\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi"
  show "alice_payoff = 3 \<and> bob_payoff = 1/2"
    using alice_payoff_def bob_payoff_def sqrt_two_squared_cpx half_sqrt_two_squared
          exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"] psi_f_is_state
    by (auto simp add: asm assms sin_45 cos_45 algebra_simps)
qed

lemma (in strategic_space_2p) max_entangled_MC:
(* Alice plays the "miracle move", and Bob plays the classical defect move in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0 \<longrightarrow> alice_payoff = 3 \<and> bob_payoff = 1/2"
proof
  assume asm:"\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = 0"
  show "alice_payoff = 3 \<and> bob_payoff = 1/2"
    using alice_payoff_def bob_payoff_def sqrt_two_squared_cpx half_sqrt_two_squared
          exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"] psi_f_is_state
    by (auto simp add: asm assms sin_45 cos_45 algebra_simps)
qed

lemma (in strategic_space_2p) max_entangled_MH:
(* Alice plays the "miracle move", and Bob plays the classical half move in the maximally entangled case *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi/2 \<longrightarrow> alice_payoff = 1 \<and> bob_payoff = 1"
proof
  assume asm:"\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>B = pi/2"
  show "alice_payoff = 1 \<and> bob_payoff = 1"
    using alice_payoff_def bob_payoff_def sqrt_two_squared_cpx half_sqrt_two_squared
          exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"] psi_f_is_state
    by (auto simp add: asm assms sin_45 cos_45 algebra_simps)
qed

(* This is the definition of M in equation (9) *)
abbreviation M :: "complex Matrix.mat" where
"M \<equiv> mat_of_cols_list 2 [[\<i> * sqrt(2)/2, -1 * sqrt(2)/2],
                          [1 * sqrt(2)/2, -\<i> * sqrt(2)/2]]"

lemma (in strategic_space_2p) M_correct:
  assumes "\<phi>\<^sub>A = pi/2 \<and> \<theta>\<^sub>A = pi/2"
  shows "U\<^sub>A = M"
proof
  show "dim_row U\<^sub>A = dim_row M" using mat_of_cols_list_def by simp
  show "dim_col U\<^sub>A = dim_col M" using mat_of_cols_list_def by simp
  fix i j assume a0:"i < dim_row M" and a1:"j < dim_col M"
  then show "U\<^sub>A $$ (i,j) = M $$ (i,j)"
  proof-
    have "i\<in>{0,1} \<and> j\<in>{0,1}"
      using a0 a1 mat_of_cols_list_def by auto
    thus ?thesis
      using mat_of_cols_list_def exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"]
      by (auto simp add: assms sin_45 cos_45)
  qed
qed

lemma hidden_sqrt_two_squared_cpx2:
  fixes x y :: complex
  shows "(sqrt 2) * ((sqrt 2) * (x * y)) / 2 = x * y"
  using sqrt_two_squared_cpx by auto

lemma (in strategic_space_2p) unfair_strategy_no_benefit:
(* Two players' payoffs in the maximally entangled case given that Alice plays a quantum move and Bob
plays a classical move with the same \<theta> *)
  assumes "\<gamma> = pi/2"
  shows "\<phi>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>A = \<theta>\<^sub>B \<longrightarrow> alice_payoff = 1 \<and> bob_payoff = 1"
proof
  assume asm:"\<phi>\<^sub>A = pi/2 \<and> \<phi>\<^sub>B = 0 \<and> \<theta>\<^sub>A = \<theta>\<^sub>B"
  have "\<psi>\<^sub>f $$ (0,0) = 0"
    using exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"]
    by (auto simp add: asm assms sin_45 cos_45 algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (1,0) = 0"
    using exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"]
    by (auto simp add: asm assms sin_45 cos_45 algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (2,0) = 0"
    using exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"]
    by (auto simp add: asm assms sin_45 cos_45 hidden_sqrt_two_squared_cpx2 algebra_simps)
  moreover have "\<psi>\<^sub>f $$ (3,0) = 1"
    using exp_of_half_pi[of "pi/2"] exp_of_minus_half_pi[of "pi/2"] cos_sin_squared_add_cpx
    by (auto simp add: asm assms sin_45 cos_45 hidden_sqrt_two_squared_cpx2 algebra_simps)
  ultimately show "alice_payoff = 1 \<and> bob_payoff = 1"
    using alice_payoff_def bob_payoff_def psi_f_is_state
    by auto
qed

(*
Bibliography:

@ARTICLE{EWL,
   author = {{Eisert}, J. and {Wilkens}, M. and {Lewenstein}, M.},
    title = "{Quantum Games and Quantum Strategies}",
  journal = {Physical Review Letters},
   eprint = {quant-ph/9806088},
     year = 1999,
    month = oct,
   volume = 83,
    pages = {3077-3080},
      doi = {10.1103/PhysRevLett.83.3077},
   adsurl = {https://ui.adsabs.harvard.edu/abs/1999PhRvL..83.3077E},
  adsnote = {Provided by the SAO/NASA Astrophysics Data System}
}
*)
end


(*  Title:      ZF/EquivClass.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*Equivalence Relations*}

theory EquivClass imports Trancl Perm begin

definition
  quotient   :: "[i,i]=>i"    (infixl "'/'/" 90)  (*set of equiv classes*)  where
      "A//r == {r``{x} . x \<in> A}"

definition
  congruent  :: "[i,i=>i]=>o"  where
      "congruent(r,b) == \<forall>y z. <y,z>:r \<longrightarrow> b(y)=b(z)"

definition
  congruent2 :: "[i,i,[i,i]=>i]=>o"  where
      "congruent2(r1,r2,b) == \<forall>y1 z1 y2 z2.
           <y1,z1>:r1 \<longrightarrow> <y2,z2>:r2 \<longrightarrow> b(y1,y2) = b(z1,z2)"

abbreviation
  RESPECTS ::"[i=>i, i] => o"  (infixr "respects" 80) where
  "f respects r == congruent(r,f)"

abbreviation
  RESPECTS2 ::"[i=>i=>i, i] => o"  (infixr "respects2 " 80) where
  "f respects2 r == congruent2(r,r,f)"
    --{*Abbreviation for the common case where the relations are identical*}

subsection{*Suppes, Theorem 70:
    @{term r} is an equiv relation iff @{term "converse(r) O r = r"}*}

(** first half: equiv(A,r) ==> converse(r) O r = r **)

lemma sym_trans_comp_subset:
    "[| sym(r); trans(r) |] ==> converse(r) O r \<subseteq> r"
by (unfold trans_def sym_def, blast)

lemma refl_comp_subset:
    "[| refl(A,r); r \<subseteq> A*A |] ==> r \<subseteq> converse(r) O r"
by (unfold refl_def, blast)

lemma equiv_comp_eq:
    "equiv(A,r) ==> converse(r) O r = r"
apply (unfold equiv_def)
apply (blast del: subsetI intro!: sym_trans_comp_subset refl_comp_subset)
done

(*second half*)
lemma comp_equivI:
    "[| converse(r) O r = r;  domain(r) = A |] ==> equiv(A,r)"
apply (unfold equiv_def refl_def sym_def trans_def)
apply (erule equalityE)
apply (subgoal_tac "\<forall>x y. <x,y> \<in> r \<longrightarrow> <y,x> \<in> r", blast+)
done

(** Equivalence classes **)

(*Lemma for the next result*)
lemma equiv_class_subset:
    "[| sym(r);  trans(r);  <a,b>: r |] ==> r``{a} \<subseteq> r``{b}"
by (unfold trans_def sym_def, blast)

lemma equiv_class_eq:
    "[| equiv(A,r);  <a,b>: r |] ==> r``{a} = r``{b}"
apply (unfold equiv_def)
apply (safe del: subsetI intro!: equalityI equiv_class_subset)
apply (unfold sym_def, blast)
done

lemma equiv_class_self:
    "[| equiv(A,r);  a \<in> A |] ==> a \<in> r``{a}"
by (unfold equiv_def refl_def, blast)

(*Lemma for the next result*)
lemma subset_equiv_class:
    "[| equiv(A,r);  r``{b} \<subseteq> r``{a};  b \<in> A |] ==> <a,b>: r"
by (unfold equiv_def refl_def, blast)

lemma eq_equiv_class: "[| r``{a} = r``{b};  equiv(A,r);  b \<in> A |] ==> <a,b>: r"
by (assumption | rule equalityD2 subset_equiv_class)+

(*thus r``{a} = r``{b} as well*)
lemma equiv_class_nondisjoint:
    "[| equiv(A,r);  x: (r``{a} \<inter> r``{b}) |] ==> <a,b>: r"
by (unfold equiv_def trans_def sym_def, blast)

lemma equiv_type: "equiv(A,r) ==> r \<subseteq> A*A"
by (unfold equiv_def, blast)

lemma equiv_class_eq_iff:
     "equiv(A,r) ==> <x,y>: r \<longleftrightarrow> r``{x} = r``{y} & x \<in> A & y \<in> A"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

lemma eq_equiv_class_iff:
     "[| equiv(A,r);  x \<in> A;  y \<in> A |] ==> r``{x} = r``{y} \<longleftrightarrow> <x,y>: r"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

(*** Quotients ***)

(** Introduction/elimination rules -- needed? **)

lemma quotientI [TC]: "x \<in> A ==> r``{x}: A//r"
apply (unfold quotient_def)
apply (erule RepFunI)
done

lemma quotientE:
    "[| X \<in> A//r;  !!x. [| X = r``{x};  x \<in> A |] ==> P |] ==> P"
by (unfold quotient_def, blast)

lemma Union_quotient:
    "equiv(A,r) ==> \<Union>(A//r) = A"
by (unfold equiv_def refl_def quotient_def, blast)

lemma quotient_disj:
    "[| equiv(A,r);  X \<in> A//r;  Y \<in> A//r |] ==> X=Y | (X \<inter> Y \<subseteq> 0)"
apply (unfold quotient_def)
apply (safe intro!: equiv_class_eq, assumption)
apply (unfold equiv_def trans_def sym_def, blast)
done

subsection{*Defining Unary Operations upon Equivalence Classes*}

(** Could have a locale with the premises equiv(A,r)  and  congruent(r,b)
**)

(*Conversion rule*)
lemma UN_equiv_class:
    "[| equiv(A,r);  b respects r;  a \<in> A |] ==> (\<Union>x\<in>r``{a}. b(x)) = b(a)"
apply (subgoal_tac "\<forall>x \<in> r``{a}. b(x) = b(a)")
 apply simp
 apply (blast intro: equiv_class_self)
apply (unfold equiv_def sym_def congruent_def, blast)
done

(*type checking of  @{term"\<Union>x\<in>r``{a}. b(x)"} *)
lemma UN_equiv_class_type:
    "[| equiv(A,r);  b respects r;  X \<in> A//r;  !!x.  x \<in> A ==> b(x) \<in> B |]
     ==> (\<Union>x\<in>X. b(x)) \<in> B"
apply (unfold quotient_def, safe)
apply (simp (no_asm_simp) add: UN_equiv_class)
done

(*Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; bcong could be !!y. y \<in> A ==> b(y):B
*)
lemma UN_equiv_class_inject:
    "[| equiv(A,r);   b respects r;
        (\<Union>x\<in>X. b(x))=(\<Union>y\<in>Y. b(y));  X \<in> A//r;  Y \<in> A//r;
        !!x y. [| x \<in> A; y \<in> A; b(x)=b(y) |] ==> <x,y>:r |]
     ==> X=Y"
apply (unfold quotient_def, safe)
apply (rule equiv_class_eq, assumption)
apply (simp add: UN_equiv_class [of A r b])
done

subsection{*Defining Binary Operations upon Equivalence Classes*}

lemma congruent2_implies_congruent:
    "[| equiv(A,r1);  congruent2(r1,r2,b);  a \<in> A |] ==> congruent(r2,b(a))"
by (unfold congruent_def congruent2_def equiv_def refl_def, blast)

lemma congruent2_implies_congruent_UN:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a \<in> A2 |] ==>
     congruent(r1, %x1. \<Union>x2 \<in> r2``{a}. b(x1,x2))"
apply (unfold congruent_def, safe)
apply (frule equiv_type [THEN subsetD], assumption)
apply clarify
apply (simp add: UN_equiv_class congruent2_implies_congruent)
apply (unfold congruent2_def equiv_def refl_def, blast)
done

lemma UN_equiv_class2:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a1: A1;  a2: A2 |]
     ==> (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. b(x1,x2)) = b(a1,a2)"
by (simp add: UN_equiv_class congruent2_implies_congruent
              congruent2_implies_congruent_UN)

(*type checking*)
lemma UN_equiv_class_type2:
    "[| equiv(A,r);  b respects2 r;
        X1: A//r;  X2: A//r;
        !!x1 x2.  [| x1: A; x2: A |] ==> b(x1,x2) \<in> B
     |] ==> (\<Union>x1\<in>X1. \<Union>x2\<in>X2. b(x1,x2)) \<in> B"
apply (unfold quotient_def, safe)
apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                    congruent2_implies_congruent quotientI)
done

(*Suggested by John Harrison -- the two subproofs may be MUCH simpler
  than the direct proof*)
lemma congruent2I:
    "[|  equiv(A1,r1);  equiv(A2,r2);
        !! y z w. [| w \<in> A2;  <y,z> \<in> r1 |] ==> b(y,w) = b(z,w);
        !! y z w. [| w \<in> A1;  <y,z> \<in> r2 |] ==> b(w,y) = b(w,z)
     |] ==> congruent2(r1,r2,b)"
apply (unfold congruent2_def equiv_def refl_def, safe)
apply (blast intro: trans)
done

lemma congruent2_commuteI:
 assumes equivA: "equiv(A,r)"
     and commute: "!! y z. [| y \<in> A;  z \<in> A |] ==> b(y,z) = b(z,y)"
     and congt:   "!! y z w. [| w \<in> A;  <y,z>: r |] ==> b(w,y) = b(w,z)"
 shows "b respects2 r"
apply (insert equivA [THEN equiv_type, THEN subsetD])
apply (rule congruent2I [OF equivA equivA])
apply (rule commute [THEN trans])
apply (rule_tac [3] commute [THEN trans, symmetric])
apply (rule_tac [5] sym)
apply (blast intro: congt)+
done

(*Obsolete?*)
lemma congruent_commuteI:
    "[| equiv(A,r);  Z \<in> A//r;
        !!w. [| w \<in> A |] ==> congruent(r, %z. b(w,z));
        !!x y. [| x \<in> A;  y \<in> A |] ==> b(y,x) = b(x,y)
     |] ==> congruent(r, %w. \<Union>z\<in>Z. b(w,z))"
apply (simp (no_asm) add: congruent_def)
apply (safe elim!: quotientE)
apply (frule equiv_type [THEN subsetD], assumption)
apply (simp add: UN_equiv_class [of A r])
apply (simp add: congruent_def)
done

end


theory Ex1
imports "HOL-Probability.Probability" "HOL-Library.Permutation"
begin

(*
Let @term{{ X\<^sub>n : n \<ge> 1 }} be IID random variables taking integer values. Let S\<^sub>0=0, S\<^sub>n = \<Sum>\<^sup>n\<^sub>i\<^sub>=\<^sub>1 X\<^sub>i.
The range R\<^sub>i of S\<^sub>0, ... , S\<^sub>n is the number of distinct values taken by the sequence.
Show that P(R\<^sub>n = R\<^sub>n\<^sub>-\<^sub>1 + 1) = P( S\<^sub>1 * .. * S\<^sub>n )

Challenge here is to write Isabelle that follows the above description of the problem.

Can we? Instead it is much easier to write it in a monadic style?

PMF for S_i

pmf_walk :: nat \<Rightarrow> (int list) pmf
pmf_walk 0 = pmf where 0 has prob 1
pmf_walk n = do {
             w <- pmf_walk (n-1)
             s <- pmf_step
             return w+s
}

pmf_range n = do {
              w <- pmf_walk n
              return (length distinct w)
   }

proof
   w <- pmf_range n
   rn <- pmf_range n
   rm <- pmf_range n-1
   prob (rn = rm + 1) = prob (mult w \<noteq> 0)

*)

sledgehammer_params[debug=true,timeout=600]

locale walk =
  fixes pmf_step :: "int pmf"
begin

fun pmf_steps :: "nat \<Rightarrow> (int list) pmf" where
"pmf_steps 0 = return_pmf []"
| "pmf_steps (Suc n) = do {
          s  \<leftarrow> pmf_step;
          ss  \<leftarrow> pmf_steps n;
          return_pmf (s#ss)
}"

lemma pmf_zero_steps_one: "pmf_steps 0 { [] } = 1"
  using pmf_steps.simps by auto

lemma pmf_zero_steps_zero:
  assumes "\<forall>x \<in> xs. length x > 0"
  shows "pmf_steps 0 xs = 0"
  using pmf_steps.simps pmf_zero_steps_one assms emeasure_pmf  by auto

(*

lemma
  assumes "\<exists>x \<in> xs. length x \<noteq> n"
  shows "pmf_steps n xs = 0"
using assms proof(induct n)
  case 0
  then show ?case using pmf_zero_steps_zero
next
  case (Suc n)
  then show ?case using pmf_steps.simps
qed
*)

definition "cons_pmf A B = bind_pmf A  (\<lambda>x. bind_pmf B (\<lambda>xs. return_pmf (x#xs)))"

lemma pmf_cons: "pmf (cons_pmf M N) (a#b) = pmf M a * pmf N b"
  unfolding cons_pmf_def pmf_bind pmf_return
  apply (subst integral_measure_pmf_real[where A="{b}"])
  apply (auto simp: indicator_eq_0_iff)
  apply (subst integral_measure_pmf_real[where A="{a}"])
  apply (auto simp: indicator_eq_0_iff sum_nonneg_eq_0_iff pmf_nonneg)
  done

thm cons_pmf_def

abbreviation mult_list :: "int list \<Rightarrow> int" where
  "mult_list xs \<equiv> fold (*) xs (1::int)"

abbreviation prob where
  "prob \<equiv> measure_pmf.prob"

lemma pmf_steps_Cons:
  fixes xs::"int list"
  assumes "length xs = n"
  shows "prob (pmf_steps (n+1)) {x#xs} = (prob pmf_step {x})  * (prob (pmf_steps n) {xs})"
proof -
  have "pmf_steps (n+1) =  cons_pmf pmf_step (pmf_steps n)"
    using pmf_steps.simps cons_pmf_def
    by (metis Suc_eq_plus1)
  hence "pmf (pmf_steps (n+1)) (x#xs) = pmf pmf_step x * pmf (pmf_steps n) xs"
    using pmf_cons by metis
  thm measure_pmf_single
  thus ?thesis using pmf_def map_fun_def measure_def
    by (metis measure_pmf_single)
  hence "pmf_steps (n+1) {x#xs} =  emeasure (measure_pmf (pmf_step \<bind> (\<lambda>s. pmf_steps n \<bind> (\<lambda>ss. return_pmf (s # ss))))) {x#xs} "
    by auto
qed

thm foldr.simps foldl.simps

lemma fold_fun:
  "g (f x)  (foldr g (list.map f xs) y) = foldr g (list.map f (x#xs)) y"
proof(induct xs)
  case Nil
  then show ?case by auto
next
  case (Cons x' xs')
  then show ?case using foldr.simps by auto
qed

thm perm.induct

lemma foldr_mult_perm:
  fixes xs::"'a :: comm_semiring_1 list"
  assumes "perm xs xs'"
  shows "foldr (*) xs 1 = foldr (*) xs' 1"
  using assms apply(induct rule: perm.inducts,auto)
  by (simp add: mult.left_commute)

(*
 lemma measure_prob_cong_0:
  assumes "\<And>x. x \<in> A - B \<Longrightarrow> pmf p x = 0"
  assumes "\<And>x. x \<in> B - A \<Longrightarrow> pmf p x = 0"
  shows   "measure (measure_pmf p) A = measure (measure_pmf p) B"
proof -
  have "measure_pmf.prob p A = measure_pmf.prob p (A \<inter> set_pmf p)"
    by (simp add: measure_Int_set_pmf)
  also have "A \<inter> set_pmf p = B \<inter> set_pmf p"
    using assms by (auto simp: set_pmf_eq)
  also have "measure_pmf.prob p \<dots> = measure_pmf.prob p B"
    by (simp add: measure_Int_set_pmf)
  finally show ?thesis .
qed
*)
(* Could just define pmf_steps to be this *)
lemma pmf_steps_foldr:
  assumes "length xs = n"
  shows "prob (pmf_steps n) {xs} = foldr (*) (list.map (\<lambda>x. prob pmf_step {x}) xs) 1"
  using assms proof(induct n arbitrary: xs)
  case 0
  then show ?case by auto
next
  case (Suc n')
  then obtain x' and xs' where *:"xs = x'#xs'" using list.distinct  by (metis length_Suc_conv)
  then have "prob (pmf_steps (Suc n')) {x'#xs'} = (prob pmf_step {x'})  * (prob (pmf_steps n') {xs'})" using pmf_steps_Cons Suc by auto
  also have "... = prob pmf_step {x'} * (foldr (*) (list.map (\<lambda>x. prob pmf_step {x}) xs') 1)" using * Suc by auto
  also have "... = (foldr (*) (list.map (\<lambda>x. prob pmf_step {x}) (x'#xs')) 1)" using fold_fun by metis
  finally show ?case using fold.simps * by simp
qed

lemma perm_map:
  assumes "perm xs xs'"
  shows "perm (map f xs) (map f xs')"
using assms by(induct rule: perm.inducts,auto)

lemma pmf_steps_perm_prob_eq:
  fixes xs::"int list"
  assumes "length xs = n" and "perm xs xs'"
  shows  "prob (pmf_steps n) {xs} = prob (pmf_steps n) {xs'}"
proof -
  have "prob (pmf_steps n) {xs} = foldr (*) (list.map (\<lambda>x. prob pmf_step {x}) xs) 1" using pmf_steps_foldr assms by simp
  also have "... =  foldr (*) (list.map (\<lambda>x. prob pmf_step {x}) xs') 1"
    using assms perm_map[THEN foldr_mult_perm, where f1="(\<lambda>x. prob pmf_step {x})"] by auto
  finally show ?thesis using pmf_steps_foldr perm_length assms by metis
qed

lemma pmf_steps_rev_prob_eq:
  assumes "length xs = n"
  shows  "prob (pmf_steps n) {xs} = prob (pmf_steps n) {rev xs}"
proof -
  have "perm xs (rev xs)"  by (simp add: perm_rev perm_sym)
  thus ?thesis using pmf_steps_perm_prob_eq assms by auto
qed

(* should be easy as can reverse * and pmf are additive over set - in fact holds for any permutation of list *)
lemma
  assumes "xss \<noteq> {}" and "\<forall>x \<in> xss. length x = n"
  shows  "prob (pmf_steps n) xss = prob (pmf_steps n) (rev ` xss)"
  using assms pmf_steps_rev_prob_eq sorry
(*
using assms proof(induct n arbitrary: xss)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case using pmf_steps.simps
qed
*)
value "prefixes [1,2,3::int]"

abbreviation sum_list :: "int list \<Rightarrow> int" where
  "sum_list xs \<equiv> fold (+) xs (0::int)"

abbreviation walk_of :: "int list \<Rightarrow> int list" where
 "walk_of xs \<equiv> map sum_list (prefixes xs)"

abbreviation walk_of2 :: "int list \<Rightarrow> int list" where
 "walk_of2 xs \<equiv> map (\<lambda>n. (\<Sum>j\<in>{0..<n}. (xs!j))) [0..<length xs+1]"

value "prefixes [1,2,3::nat]"

thm prefixes_snoc

value "walk_of [-1,-2]"

lemma walk_of_snoc:
  "walk_of (xs@[x]) = (walk_of xs) @ [ last (walk_of xs) + x ]"
proof(induct xs rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x' xs')
  then show ?case using prefixes_snoc sorry
qed

lemma "walk_of xs = map (\<lambda>n. (\<Sum>j\<in>{0..<n}. (xs!j))) [0..<length xs+1]"
proof(induct xs rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc  x' xs')
  let ?w = "map (\<lambda>n. (\<Sum>j\<in>{0..<n}. (xs'!j))) [0..<length xs'+1]"
  have "walk_of (xs'@[x']) = (walk_of xs') @ [ last (walk_of xs') + x' ]"
    using walk_of_snoc by metis
  also have "... = ?w @ [ last ?w + x' ]" using snoc by simp
  also have "... = map (\<lambda>n. (\<Sum>j\<in>{0..<n}. ((xs'@[x'])!j))) [0..<length (xs'@[x'])+1]"
    using snoc sorry
  finally show ?case by auto
(*  show  "walk_of (xs'@[x']) =  map (\<lambda>n. (\<Sum>j\<in>{0..<n}. ((xs'@[x'])!j))) [0..<length (xs'@[x'])+1]" sorry*)
qed

value "walk_of [1,2,4]"

abbreviation range_of :: "int list \<Rightarrow> nat" where
  "range_of xs \<equiv> length (remdups xs)"

abbreviation ranges_of :: "int list \<Rightarrow> nat list" where
  "ranges_of xs \<equiv> drop 1 (map range_of (prefixes xs))"

value "range_of (walk_of [1,2,2])"
value "prefixes (walk_of [1,2,2])"
value "ranges_of (walk_of [1,2,-2])"

abbreviation steps_non_zero :: "int list \<Rightarrow> bool" where
  "steps_non_zero xs \<equiv> (mult_list (drop 1 (walk_of xs)) \<noteq> 0)"

value "steps_non_zero [1,2,-2,-1]"

(*
abbreviation drop_last :: "'a list \<Rightarrow> 'a list" where
  "drop_last xs \<equiv> take ((length xs) - 1) xs"

value "drop_last [1,2,3]::(nat list)"
*)

abbreviation range_inc :: "int list \<Rightarrow> bool" where
  "range_inc xs \<equiv> (let rn = range_of (walk_of xs) in
                   let rns = range_of (butlast (walk_of xs)) in
                   rn = rns + 1)"

value "range_of [1,2,-2]"

value "range_inc [1,2,-2,-2]"

value "walk_of [- 2, 0]"

value "range_of (walk_of [- 2, 0])"
value "range_of (walk_of [-2])"

value "steps_non_zero [- 2, 0]"
value "range_inc [- 2, 0]"

lemma butlast_append_last_eq:
  assumes "length xs > 0"
  shows   "(butlast xs)  @ [last xs] = xs"
using assms proof(induct xs)
  case Nil
  then show ?case by auto
next
  case (Cons x' xs')
  then show ?case by auto
qed

lemma  last_remdups:
  assumes "last xs \<in> set (butlast xs)" and "length xs > 0"
  shows "set (remdups xs) = set (remdups (butlast xs))"
  using assms apply(induct xs,simp)
  by (metis ex1.butlast_append_last_eq remdups.simps(2) rotate1.simps(2) set_remdups set_rotate1)

value "walk_of [-1]"
value "range_inc [- 1]"

lemma range_inc_neq:
  assumes "range_inc xs"
  shows "\<forall>i \<in> { 0..<(length xs)}. last (walk_of xs) \<noteq> (walk_of xs)!i"
proof
  fix i
  assume as:"i \<in> { 0..<(length xs)}"
  show "last (walk_of xs) \<noteq> (walk_of xs)!i" proof
    assume *: "last (walk_of xs) = (walk_of xs)!i"

    have "range_of (walk_of xs) =  range_of (butlast (walk_of xs))" proof -
      have "length (walk_of xs) = length xs + 1" by auto
      hence "i < length (walk_of xs) - 1" using as by simp
      hence "(walk_of xs)!i \<in> set (butlast (walk_of xs))" using butlast.simps
        by (metis in_set_conv_nth length_butlast nth_butlast)
      hence "last (walk_of xs) \<in> set (butlast (walk_of xs)) \<and> 0 < length (walk_of xs)" using * by simp
      hence "set (remdups  (walk_of xs)) = set (remdups (butlast (walk_of xs)))"  using * as last_remdups by metis
      hence "length (remdups  (walk_of xs)) = length (remdups (butlast (walk_of xs)))"
        by (metis card'_code(1) set_remdups)
      thus ?thesis by simp
    qed
    thus False using assms by auto
  qed
qed

value "walk_of [-1]"

lemma xx:
  assumes "i \<in> { 1..length xs}"
  shows "(walk_of xs)!i = xs!(i-1) + (walk_of xs)!(i-1)"
  using assms proof(induct xs)
case Nil
  then show ?case by auto
next
  case (Cons x' xs')
  then show ?case sledgehammer
qed

lemma range_inc_neq2:
  assumes "range_inc xs" and "i \<in> { 0..<(length xs)}" and "last (walk_of xs) \<noteq> (walk_of xs)!i"
  shows "(\<Sum> j \<in> {i..length xs}. (xs!j)) \<noteq> 0"
proof -
  have "(walk_of xs)!i =

  using assms sledgehammer

(*}
  thus ?thesis using list_all_simps

  case Nil
  then show ?case by auto
next
  case (Cons x' xs')

  have "last_of (walk_of (x'#xs')) \<noteq> x'" sorry
  moreover have "list_all (\<lambda>s. last_of (walk_of (x'#xs')) \<noteq> s) (drop_last (walk_of (xs')))" sorry
  ultimately have "list_all (\<lambda>s. last_of (walk_of (x'#xs')) \<noteq> s) (x'#(drop_last (walk_of (xs'))))" by auto

  thus ?case
(*"list_all (\<lambda>s. last_of (walk_of (x'#xs')) \<noteq> s) (drop_last (walk_of (x'#xs')))"*)

(*  have "list_all (\<lambda>s. last_of (walk_of xs) \<noteq> s) (drop_last (walk_of xs)) =
            (last_of (walk_of (x'xxs) \<noteq> x') \<and> list_all (\<lambda>s. last_of (walk_of xs') \<noteq> s) (drop_last (walk_of xs'))"

  have "range_inc xs' \<Longrightarrow>  list_all (\<lambda>s. last_of (walk_of xs') \<noteq> s) (drop_last (walk_of xs'))"
  have "length (walk_of xs') > 0" by auto
  then obtain ls where "ls = last_of (walk_of xs')" using last_of.simps by simp

  then show ?case *)
qed
*)

lemma
  shows "prob (pmf_steps n) { xs . length xs = n \<and> range_inc xs } = prob (pmf_steps n) { xs . length xs = n \<and> steps_non_zero xs }"
proof -
  fix xs
  assume "length xs = n" and "range_inc xs"
  have "list_all (\<lambda>s. last_of (walk_of xs) \<noteq> s) (drop_last (walk_of xs))"
(*
lemma "steps_non_zero xs = range_inc xs"

lemma "{xs . steps_non_zero xs } = { xs. range_inc xs }"
proof -
  have "{xs . steps_non_zero xs } \<subseteq> { xs. range_inc xs }"
  proof -
    fix xs
    assume "steps_non_zero xs"
    have "range_inc xs" sorry
  *)

(*

fun pmf_walk :: "nat \<Rightarrow> (int list) pmf" where
"pmf_walk 0 = return_pmf [0]"
| "pmf_walk n = do {
          w \<leftarrow> pmf_walk (n-1);
          case w of
               (w#ws) \<Rightarrow> do {
                              s \<leftarrow> pmf_step;
                              return_pmf ((s+w)#w#ws)
                        }
              | _ \<Rightarrow> return_pmf [0]
}"

fun pmf_lhs :: "nat \<Rightarrow> bool pmf" where
"pmf_lhs 0 = return_pmf True"
|  "pmf_lhs n = do {
         w \<leftarrow> pmf_walk n;
         s0 \<leftarrow> return_pmf (((mult_list w) = (0::int)));
         s1 \<leftarrow> return_pmf ((range_of w) = ((range_of (tl w)) + (1::int)));
         return_pmf (s0 =  s1)
}"
*)


(*  Title:      HOL/Lattices_Big.thy
    Author:     Tobias Nipkow, Lawrence C Paulson and Markus Wenzel
                with contributions by Jeremy Avigad
*)

section \<open>Big infimum (minimum) and supremum (maximum) over finite (non-empty) sets\<close>

theory Lattices_Big
imports Finite_Set Option
begin

subsection \<open>Generic lattice operations over a set\<close>

subsubsection \<open>Without neutral element\<close>

locale semilattice_set = semilattice
begin

interpretation comp_fun_idem f
  by standard (simp_all add: fun_eq_iff left_commute)

definition F :: "'a set \<Rightarrow> 'a"
where
  eq_fold': "F A = the (Finite_Set.fold (\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)) None A)"

lemma eq_fold:
  assumes "finite A"
  shows "F (insert x A) = Finite_Set.fold f x A"
proof (rule sym)
  let ?f = "\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)"
  interpret comp_fun_idem "?f"
    by standard (simp_all add: fun_eq_iff commute left_commute split: option.split)
  from assms show "Finite_Set.fold f x A = F (insert x A)"
  proof induct
    case empty then show ?case by (simp add: eq_fold')
  next
    case (insert y B) then show ?case by (simp add: insert_commute [of x] eq_fold')
  qed
qed

lemma singleton [simp]:
  "F {x} = x"
  by (simp add: eq_fold)

lemma insert_not_elem:
  assumes "finite A" and "x \<notin> A" and "A \<noteq> {}"
  shows "F (insert x A) = x \<^bold>* F A"
proof -
  from \<open>A \<noteq> {}\<close> obtain b where "b \<in> A" by blast
  then obtain B where *: "A = insert b B" "b \<notin> B" by (blast dest: mk_disjoint_insert)
  with \<open>finite A\<close> and \<open>x \<notin> A\<close>
    have "finite (insert x B)" and "b \<notin> insert x B" by auto
  then have "F (insert b (insert x B)) = x \<^bold>* F (insert b B)"
    by (simp add: eq_fold)
  then show ?thesis by (simp add: * insert_commute)
qed

lemma in_idem:
  assumes "finite A" and "x \<in> A"
  shows "x \<^bold>* F A = F A"
proof -
  from assms have "A \<noteq> {}" by auto
  with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
    by (induct A rule: finite_ne_induct) (auto simp add: ac_simps insert_not_elem)
qed

lemma insert [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "F (insert x A) = x \<^bold>* F A"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb in_idem insert_not_elem)

lemma union:
  assumes "finite A" "A \<noteq> {}" and "finite B" "B \<noteq> {}"
  shows "F (A \<union> B) = F A \<^bold>* F B"
  using assms by (induct A rule: finite_ne_induct) (simp_all add: ac_simps)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F A = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
proof -
  from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
  with assms show ?thesis by simp
qed

lemma insert_remove:
  assumes "finite A"
  shows "F (insert x A) = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)

lemma closed:
  assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
  shows "F A \<in> A"
using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
  case singleton then show ?case by simp
next
  case insert with elem show ?case by force
qed

lemma hom_commute:
  assumes hom: "\<And>x y. h (x \<^bold>* y) = h x \<^bold>* h y"
  and N: "finite N" "N \<noteq> {}"
  shows "h (F N) = F (h ` N)"
using N proof (induct rule: finite_ne_induct)
  case singleton thus ?case by simp
next
  case (insert n N)
  then have "h (F (insert n N)) = h (n \<^bold>* F N)" by simp
  also have "\<dots> = h n \<^bold>* h (F N)" by (rule hom)
  also have "h (F N) = F (h ` N)" by (rule insert)
  also have "h n \<^bold>* \<dots> = F (insert (h n) (h ` N))"
    using insert by simp
  also have "insert (h n) (h ` N) = h ` insert n N" by simp
  finally show ?case .
qed

lemma infinite: "\<not> finite A \<Longrightarrow> F A = the None"
  unfolding eq_fold' by (cases "finite (UNIV::'a set)") (auto intro: finite_subset fold_infinite)

end

locale semilattice_order_set = binary?: semilattice_order + semilattice_set
begin

lemma bounded_iff:
  assumes "finite A" and "A \<noteq> {}"
  shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
  using assms by (induct rule: finite_ne_induct) (simp_all add: bounded_iff)

lemma boundedI:
  assumes "finite A"
  assumes "A \<noteq> {}"
  assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  shows "x \<^bold>\<le> F A"
  using assms by (simp add: bounded_iff)

lemma boundedE:
  assumes "finite A" and "A \<noteq> {}" and "x \<^bold>\<le> F A"
  obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  using assms by (simp add: bounded_iff)

lemma coboundedI:
  assumes "finite A"
    and "a \<in> A"
  shows "F A \<^bold>\<le> a"
proof -
  from assms have "A \<noteq> {}" by auto
  from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
  proof (induct rule: finite_ne_induct)
    case singleton thus ?case by (simp add: refl)
  next
    case (insert x B)
    from insert have "a = x \<or> a \<in> B" by simp
    then show ?case using insert by (auto intro: coboundedI2)
  qed
qed

lemma antimono:
  assumes "A \<subseteq> B" and "A \<noteq> {}" and "finite B"
  shows "F B \<^bold>\<le> F A"
proof (cases "A = B")
  case True then show ?thesis by (simp add: refl)
next
  case False
  have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
  then have "F B = F (A \<union> (B - A))" by simp
  also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
  also have "\<dots> \<^bold>\<le> F A" by simp
  finally show ?thesis .
qed

end

subsubsection \<open>With neutral element\<close>

locale semilattice_neutr_set = semilattice_neutr
begin

interpretation comp_fun_idem f
  by standard (simp_all add: fun_eq_iff left_commute)

definition F :: "'a set \<Rightarrow> 'a"
where
  eq_fold: "F A = Finite_Set.fold f \<^bold>1 A"

lemma infinite [simp]:
  "\<not> finite A \<Longrightarrow> F A = \<^bold>1"
  by (simp add: eq_fold)

lemma empty [simp]:
  "F {} = \<^bold>1"
  by (simp add: eq_fold)

lemma insert [simp]:
  assumes "finite A"
  shows "F (insert x A) = x \<^bold>* F A"
  using assms by (simp add: eq_fold)

lemma in_idem:
  assumes "finite A" and "x \<in> A"
  shows "x \<^bold>* F A = F A"
proof -
  from assms have "A \<noteq> {}" by auto
  with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
    by (induct A rule: finite_ne_induct) (auto simp add: ac_simps)
qed

lemma union:
  assumes "finite A" and "finite B"
  shows "F (A \<union> B) = F A \<^bold>* F B"
  using assms by (induct A) (simp_all add: ac_simps)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F A = x \<^bold>* F (A - {x})"
proof -
  from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
  with assms show ?thesis by simp
qed

lemma insert_remove:
  assumes "finite A"
  shows "F (insert x A) = x \<^bold>* F (A - {x})"
  using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)

lemma subset:
  assumes "finite A" and "B \<subseteq> A"
  shows "F B \<^bold>* F A = F A"
proof -
  from assms have "finite B" by (auto dest: finite_subset)
  with assms show ?thesis by (simp add: union [symmetric] Un_absorb1)
qed

lemma closed:
  assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
  shows "F A \<in> A"
using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
  case singleton then show ?case by simp
next
  case insert with elem show ?case by force
qed

end

locale semilattice_order_neutr_set = binary?: semilattice_neutr_order + semilattice_neutr_set
begin

lemma bounded_iff:
  assumes "finite A"
  shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
  using assms by (induct A) (simp_all add: bounded_iff)

lemma boundedI:
  assumes "finite A"
  assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  shows "x \<^bold>\<le> F A"
  using assms by (simp add: bounded_iff)

lemma boundedE:
  assumes "finite A" and "x \<^bold>\<le> F A"
  obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
  using assms by (simp add: bounded_iff)

lemma coboundedI:
  assumes "finite A"
    and "a \<in> A"
  shows "F A \<^bold>\<le> a"
proof -
  from assms have "A \<noteq> {}" by auto
  from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
  proof (induct rule: finite_ne_induct)
    case singleton thus ?case by (simp add: refl)
  next
    case (insert x B)
    from insert have "a = x \<or> a \<in> B" by simp
    then show ?case using insert by (auto intro: coboundedI2)
  qed
qed

lemma antimono:
  assumes "A \<subseteq> B" and "finite B"
  shows "F B \<^bold>\<le> F A"
proof (cases "A = B")
  case True then show ?thesis by (simp add: refl)
next
  case False
  have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
  then have "F B = F (A \<union> (B - A))" by simp
  also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
  also have "\<dots> \<^bold>\<le> F A" by simp
  finally show ?thesis .
qed

end

subsection \<open>Lattice operations on finite sets\<close>

context semilattice_inf
begin

sublocale Inf_fin: semilattice_order_set inf less_eq less
defines
  Inf_fin ("\<Sqinter>\<^sub>f\<^sub>i\<^sub>n_" [900] 900) = Inf_fin.F ..

end

context semilattice_sup
begin

sublocale Sup_fin: semilattice_order_set sup greater_eq greater
defines
  Sup_fin ("\<Squnion>\<^sub>f\<^sub>i\<^sub>n_" [900] 900) = Sup_fin.F ..

end

subsection \<open>Infimum and Supremum over non-empty sets\<close>

context lattice
begin

lemma Inf_fin_le_Sup_fin [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA"
proof -
  from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by blast
  with \<open>finite A\<close> have "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> a" by (rule Inf_fin.coboundedI)
  moreover from \<open>finite A\<close> \<open>a \<in> A\<close> have "a \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA" by (rule Sup_fin.coboundedI)
  ultimately show ?thesis by (rule order_trans)
qed

lemma sup_Inf_absorb [simp]:
  "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> \<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<squnion> a = a"
  by (rule sup_absorb2) (rule Inf_fin.coboundedI)

lemma inf_Sup_absorb [simp]:
  "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> a \<sqinter> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA = a"
  by (rule inf_absorb1) (rule Sup_fin.coboundedI)

end

context distrib_lattice
begin

lemma sup_Inf1_distrib:
  assumes "finite A"
    and "A \<noteq> {}"
  shows "sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x a|a. a \<in> A}"
using assms by (simp add: image_def Inf_fin.hom_commute [where h="sup x", OF sup_inf_distrib1])
  (rule arg_cong [where f="Inf_fin"], blast)

lemma sup_Inf2_distrib:
  assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
  shows "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
  case singleton then show ?case
    by (simp add: sup_Inf1_distrib [OF B])
next
  case (insert x A)
  have finB: "finite {sup x b |b. b \<in> B}"
    by (rule finite_surj [where f = "sup x", OF B(1)], auto)
  have finAB: "finite {sup a b |a b. a \<in> A \<and> b \<in> B}"
  proof -
    have "{sup a b |a b. a \<in> A \<and> b \<in> B} = (UN a:A. UN b:B. {sup a b})"
      by blast
    thus ?thesis by(simp add: insert(1) B(1))
  qed
  have ne: "{sup a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
  have "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = sup (inf x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)"
    using insert by simp
  also have "\<dots> = inf (sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)) (sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB))" by(rule sup_inf_distrib2)
  also have "\<dots> = inf (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x b|b. b \<in> B}) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B})"
    using insert by(simp add:sup_Inf1_distrib[OF B])
  also have "\<dots> = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n({sup x b |b. b \<in> B} \<union> {sup a b |a b. a \<in> A \<and> b \<in> B})"
    (is "_ = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n?M")
    using B insert
    by (simp add: Inf_fin.union [OF finB _ finAB ne])
  also have "?M = {sup a b |a b. a \<in> insert x A \<and> b \<in> B}"
    by blast
  finally show ?case .
qed

lemma inf_Sup1_distrib:
  assumes "finite A" and "A \<noteq> {}"
  shows "inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x a|a. a \<in> A}"
using assms by (simp add: image_def Sup_fin.hom_commute [where h="inf x", OF inf_sup_distrib1])
  (rule arg_cong [where f="Sup_fin"], blast)

lemma inf_Sup2_distrib:
  assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
  shows "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
  case singleton thus ?case
    by(simp add: inf_Sup1_distrib [OF B])
next
  case (insert x A)
  have finB: "finite {inf x b |b. b \<in> B}"
    by(rule finite_surj[where f = "%b. inf x b", OF B(1)], auto)
  have finAB: "finite {inf a b |a b. a \<in> A \<and> b \<in> B}"
  proof -
    have "{inf a b |a b. a \<in> A \<and> b \<in> B} = (UN a:A. UN b:B. {inf a b})"
      by blast
    thus ?thesis by(simp add: insert(1) B(1))
  qed
  have ne: "{inf a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
  have "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = inf (sup x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)"
    using insert by simp
  also have "\<dots> = sup (inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)) (inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB))" by(rule inf_sup_distrib2)
  also have "\<dots> = sup (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x b|b. b \<in> B}) (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B})"
    using insert by(simp add:inf_Sup1_distrib[OF B])
  also have "\<dots> = \<Squnion>\<^sub>f\<^sub>i\<^sub>n({inf x b |b. b \<in> B} \<union> {inf a b |a b. a \<in> A \<and> b \<in> B})"
    (is "_ = \<Squnion>\<^sub>f\<^sub>i\<^sub>n?M")
    using B insert
    by (simp add: Sup_fin.union [OF finB _ finAB ne])
  also have "?M = {inf a b |a b. a \<in> insert x A \<and> b \<in> B}"
    by blast
  finally show ?case .
qed

end

context complete_lattice
begin

lemma Inf_fin_Inf:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA = \<Sqinter>A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Inf_fin.eq_fold inf_Inf_fold_inf inf.commute [of b])
qed

lemma Sup_fin_Sup:
  assumes "finite A" and "A \<noteq> {}"
  shows "\<Squnion>\<^sub>f\<^sub>i\<^sub>nA = \<Squnion>A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Sup_fin.eq_fold sup_Sup_fold_sup sup.commute [of b])
qed

end

subsection \<open>Minimum and Maximum over non-empty sets\<close>

context linorder
begin

sublocale Min: semilattice_order_set min less_eq less
  + Max: semilattice_order_set max greater_eq greater
defines
  Min = Min.F and Max = Max.F ..

end

text \<open>An aside: @{const Min}/@{const Max} on linear orders as special case of @{const Inf_fin}/@{const Sup_fin}\<close>

lemma Inf_fin_Min:
  "Inf_fin = (Min :: 'a::{semilattice_inf, linorder} set \<Rightarrow> 'a)"
  by (simp add: Inf_fin_def Min_def inf_min)

lemma Sup_fin_Max:
  "Sup_fin = (Max :: 'a::{semilattice_sup, linorder} set \<Rightarrow> 'a)"
  by (simp add: Sup_fin_def Max_def sup_max)

context linorder
begin

lemma dual_min:
  "ord.min greater_eq = max"
  by (auto simp add: ord.min_def max_def fun_eq_iff)

lemma dual_max:
  "ord.max greater_eq = min"
  by (auto simp add: ord.max_def min_def fun_eq_iff)

lemma dual_Min:
  "linorder.Min greater_eq = Max"
proof -
  interpret dual: linorder greater_eq greater by (fact dual_linorder)
  show ?thesis by (simp add: dual.Min_def dual_min Max_def)
qed

lemma dual_Max:
  "linorder.Max greater_eq = Min"
proof -
  interpret dual: linorder greater_eq greater by (fact dual_linorder)
  show ?thesis by (simp add: dual.Max_def dual_max Min_def)
qed

lemmas Min_singleton = Min.singleton
lemmas Max_singleton = Max.singleton
lemmas Min_insert = Min.insert
lemmas Max_insert = Max.insert
lemmas Min_Un = Min.union
lemmas Max_Un = Max.union
lemmas hom_Min_commute = Min.hom_commute
lemmas hom_Max_commute = Max.hom_commute

lemma Min_in [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "Min A \<in> A"
  using assms by (auto simp add: min_def Min.closed)

lemma Max_in [simp]:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max A \<in> A"
  using assms by (auto simp add: max_def Max.closed)

lemma Min_insert2:
  assumes "finite A" and min: "\<And>b. b \<in> A \<Longrightarrow> a \<le> b"
  shows "Min (insert a A) = a"
proof (cases "A = {}")
  case True
  then show ?thesis by simp
next
  case False
  with \<open>finite A\<close> have "Min (insert a A) = min a (Min A)"
    by simp
  moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> min have "a \<le> Min A" by simp
  ultimately show ?thesis by (simp add: min.absorb1)
qed

lemma Max_insert2:
  assumes "finite A" and max: "\<And>b. b \<in> A \<Longrightarrow> b \<le> a"
  shows "Max (insert a A) = a"
proof (cases "A = {}")
  case True
  then show ?thesis by simp
next
  case False
  with \<open>finite A\<close> have "Max (insert a A) = max a (Max A)"
    by simp
  moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> max have "Max A \<le> a" by simp
  ultimately show ?thesis by (simp add: max.absorb1)
qed

lemma Min_le [simp]:
  assumes "finite A" and "x \<in> A"
  shows "Min A \<le> x"
  using assms by (fact Min.coboundedI)

lemma Max_ge [simp]:
  assumes "finite A" and "x \<in> A"
  shows "x \<le> Max A"
  using assms by (fact Max.coboundedI)

lemma Min_eqI:
  assumes "finite A"
  assumes "\<And>y. y \<in> A \<Longrightarrow> y \<ge> x"
    and "x \<in> A"
  shows "Min A = x"
proof (rule antisym)
  from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
  with assms show "Min A \<ge> x" by simp
next
  from assms show "x \<ge> Min A" by simp
qed

lemma Max_eqI:
  assumes "finite A"
  assumes "\<And>y. y \<in> A \<Longrightarrow> y \<le> x"
    and "x \<in> A"
  shows "Max A = x"
proof (rule antisym)
  from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
  with assms show "Max A \<le> x" by simp
next
  from assms show "x \<le> Max A" by simp
qed

context
  fixes A :: "'a set"
  assumes fin_nonempty: "finite A" "A \<noteq> {}"
begin

lemma Min_ge_iff [simp]:
  "x \<le> Min A \<longleftrightarrow> (\<forall>a\<in>A. x \<le> a)"
  using fin_nonempty by (fact Min.bounded_iff)

lemma Max_le_iff [simp]:
  "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
  using fin_nonempty by (fact Max.bounded_iff)

lemma Min_gr_iff [simp]:
  "x < Min A \<longleftrightarrow> (\<forall>a\<in>A. x < a)"
  using fin_nonempty  by (induct rule: finite_ne_induct) simp_all

lemma Max_less_iff [simp]:
  "Max A < x \<longleftrightarrow> (\<forall>a\<in>A. a < x)"
  using fin_nonempty by (induct rule: finite_ne_induct) simp_all

lemma Min_le_iff:
  "Min A \<le> x \<longleftrightarrow> (\<exists>a\<in>A. a \<le> x)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_le_iff_disj)

lemma Max_ge_iff:
  "x \<le> Max A \<longleftrightarrow> (\<exists>a\<in>A. x \<le> a)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: le_max_iff_disj)

lemma Min_less_iff:
  "Min A < x \<longleftrightarrow> (\<exists>a\<in>A. a < x)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_less_iff_disj)

lemma Max_gr_iff:
  "x < Max A \<longleftrightarrow> (\<exists>a\<in>A. x < a)"
  using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: less_max_iff_disj)

end

lemma Max_eq_if:
  assumes "finite A"  "finite B"  "\<forall>a\<in>A. \<exists>b\<in>B. a \<le> b"  "\<forall>b\<in>B. \<exists>a\<in>A. b \<le> a"
  shows "Max A = Max B"
proof cases
  assume "A = {}" thus ?thesis using assms by simp
next
  assume "A \<noteq> {}" thus ?thesis using assms
    by(blast intro: antisym Max_in Max_ge_iff[THEN iffD2])
qed

lemma Min_antimono:
  assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
  shows "Min N \<le> Min M"
  using assms by (fact Min.antimono)

lemma Max_mono:
  assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
  shows "Max M \<le> Max N"
  using assms by (fact Max.antimono)

end

context linorder  (* FIXME *)
begin

lemma mono_Min_commute:
  assumes "mono f"
  assumes "finite A" and "A \<noteq> {}"
  shows "f (Min A) = Min (f ` A)"
proof (rule linorder_class.Min_eqI [symmetric])
  from \<open>finite A\<close> show "finite (f ` A)" by simp
  from assms show "f (Min A) \<in> f ` A" by simp
  fix x
  assume "x \<in> f ` A"
  then obtain y where "y \<in> A" and "x = f y" ..
  with assms have "Min A \<le> y" by auto
  with \<open>mono f\<close> have "f (Min A) \<le> f y" by (rule monoE)
  with \<open>x = f y\<close> show "f (Min A) \<le> x" by simp
qed

lemma mono_Max_commute:
  assumes "mono f"
  assumes "finite A" and "A \<noteq> {}"
  shows "f (Max A) = Max (f ` A)"
proof (rule linorder_class.Max_eqI [symmetric])
  from \<open>finite A\<close> show "finite (f ` A)" by simp
  from assms show "f (Max A) \<in> f ` A" by simp
  fix x
  assume "x \<in> f ` A"
  then obtain y where "y \<in> A" and "x = f y" ..
  with assms have "y \<le> Max A" by auto
  with \<open>mono f\<close> have "f y \<le> f (Max A)" by (rule monoE)
  with \<open>x = f y\<close> show "x \<le> f (Max A)" by simp
qed

lemma finite_linorder_max_induct [consumes 1, case_names empty insert]:
  assumes fin: "finite A"
  and empty: "P {}"
  and insert: "\<And>b A. finite A \<Longrightarrow> \<forall>a\<in>A. a < b \<Longrightarrow> P A \<Longrightarrow> P (insert b A)"
  shows "P A"
using fin empty insert
proof (induct rule: finite_psubset_induct)
  case (psubset A)
  have IH: "\<And>B. \<lbrakk>B < A; P {}; (\<And>A b. \<lbrakk>finite A; \<forall>a\<in>A. a<b; P A\<rbrakk> \<Longrightarrow> P (insert b A))\<rbrakk> \<Longrightarrow> P B" by fact
  have fin: "finite A" by fact
  have empty: "P {}" by fact
  have step: "\<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. a < b; P A\<rbrakk> \<Longrightarrow> P (insert b A)" by fact
  show "P A"
  proof (cases "A = {}")
    assume "A = {}"
    then show "P A" using \<open>P {}\<close> by simp
  next
    let ?B = "A - {Max A}"
    let ?A = "insert (Max A) ?B"
    have "finite ?B" using \<open>finite A\<close> by simp
    assume "A \<noteq> {}"
    with \<open>finite A\<close> have "Max A : A" by auto
    then have A: "?A = A" using insert_Diff_single insert_absorb by auto
    then have "P ?B" using \<open>P {}\<close> step IH [of ?B] by blast
    moreover
    have "\<forall>a\<in>?B. a < Max A" using Max_ge [OF \<open>finite A\<close>] by fastforce
    ultimately show "P A" using A insert_Diff_single step [OF \<open>finite ?B\<close>] by fastforce
  qed
qed

lemma finite_linorder_min_induct [consumes 1, case_names empty insert]:
  "\<lbrakk>finite A; P {}; \<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. b < a; P A\<rbrakk> \<Longrightarrow> P (insert b A)\<rbrakk> \<Longrightarrow> P A"
  by (rule linorder.finite_linorder_max_induct [OF dual_linorder])

lemma Least_Min:
  assumes "finite {a. P a}" and "\<exists>a. P a"
  shows "(LEAST a. P a) = Min {a. P a}"
proof -
  { fix A :: "'a set"
    assume A: "finite A" "A \<noteq> {}"
    have "(LEAST a. a \<in> A) = Min A"
    using A proof (induct A rule: finite_ne_induct)
      case singleton show ?case by (rule Least_equality) simp_all
    next
      case (insert a A)
      have "(LEAST b. b = a \<or> b \<in> A) = min a (LEAST a. a \<in> A)"
        by (auto intro!: Least_equality simp add: min_def not_le Min_le_iff insert.hyps dest!: less_imp_le)
      with insert show ?case by simp
    qed
  } from this [of "{a. P a}"] assms show ?thesis by simp
qed

lemma infinite_growing:
  assumes "X \<noteq> {}"
  assumes *: "\<And>x. x \<in> X \<Longrightarrow> \<exists>y\<in>X. y > x"
  shows "\<not> finite X"
proof
  assume "finite X"
  with \<open>X \<noteq> {}\<close> have "Max X \<in> X" "\<forall>x\<in>X. x \<le> Max X"
    by auto
  with *[of "Max X"] show False
    by auto
qed

end

context linordered_ab_semigroup_add
begin

lemma add_Min_commute:
  fixes k
  assumes "finite N" and "N \<noteq> {}"
  shows "k + Min N = Min {k + m | m. m \<in> N}"
proof -
  have "\<And>x y. k + min x y = min (k + x) (k + y)"
    by (simp add: min_def not_le)
      (blast intro: antisym less_imp_le add_left_mono)
  with assms show ?thesis
    using hom_Min_commute [of "plus k" N]
    by simp (blast intro: arg_cong [where f = Min])
qed

lemma add_Max_commute:
  fixes k
  assumes "finite N" and "N \<noteq> {}"
  shows "k + Max N = Max {k + m | m. m \<in> N}"
proof -
  have "\<And>x y. k + max x y = max (k + x) (k + y)"
    by (simp add: max_def not_le)
      (blast intro: antisym less_imp_le add_left_mono)
  with assms show ?thesis
    using hom_Max_commute [of "plus k" N]
    by simp (blast intro: arg_cong [where f = Max])
qed

end

context linordered_ab_group_add
begin

lemma minus_Max_eq_Min [simp]:
  "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Max S = Min (uminus ` S)"
  by (induct S rule: finite_ne_induct) (simp_all add: minus_max_eq_min)

lemma minus_Min_eq_Max [simp]:
  "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Min S = Max (uminus ` S)"
  by (induct S rule: finite_ne_induct) (simp_all add: minus_min_eq_max)

end

context complete_linorder
begin

lemma Min_Inf:
  assumes "finite A" and "A \<noteq> {}"
  shows "Min A = Inf A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Min.eq_fold complete_linorder_inf_min [symmetric] inf_Inf_fold_inf inf.commute [of b])
qed

lemma Max_Sup:
  assumes "finite A" and "A \<noteq> {}"
  shows "Max A = Sup A"
proof -
  from assms obtain b B where "A = insert b B" and "finite B" by auto
  then show ?thesis
    by (simp add: Max.eq_fold complete_linorder_sup_max [symmetric] sup_Sup_fold_sup sup.commute [of b])
qed

end

end