(* Author: Thiemann *)
subsection \<open>The Perron Frobenius Theorem for Irreducible Matrices\<close>

theory Perron_Frobenius_Irreducible
imports
  Perron_Frobenius
  Roots_Unity
  Rank_Nullity_Theorem.Miscellaneous (* for scalar-matrix-multiplication,
    this import is incompatible with field_simps, ac_simps *)
begin

lifting_forget vec.lifting
lifting_forget mat.lifting
lifting_forget poly.lifting

lemma charpoly_of_real: "charpoly (map_matrix complex_of_real A) = map_poly of_real (charpoly A)"
  by (transfer_hma rule: of_real_hom.char_poly_hom)

context includes lifting_syntax
begin
lemma HMA_M_smult[transfer_rule]: "((=) ===> HMA_M ===> HMA_M) (\<cdot>\<^sub>m) ((*k))"
  unfolding smult_mat_def
  unfolding rel_fun_def HMA_M_def from_hma\<^sub>m_def
  by (auto simp: matrix_scalar_mult_def)
end

lemma order_charpoly_smult: fixes A :: "complex ^ 'n ^ 'n"
  assumes k: "k \<noteq> 0"
  shows "order x (charpoly (k *k A)) = order (x / k) (charpoly A)"
  by (transfer fixing: k, rule order_char_poly_smult[OF _ k])

(* use field, since the *k-lemmas have been stated for fields *)

lemma smult_eigen_value: fixes a :: "'a :: field"
  assumes "eigen_value A x"
  shows "eigen_value (a *k A) (a * x)"
  using assms smult_eigen_vector[of A _ x a] unfolding eigen_value_def by blast

locale fixed_mat = fixes A :: "'a :: zero ^ 'n ^ 'n"
begin
definition G :: "'n rel" where
  "G = { (i,j). A $ i $ j \<noteq> 0}"

definition irreducible :: bool where
  "irreducible = (UNIV \<subseteq> G^+)"
end

lemma G_transpose:
  "fixed_mat.G (transpose A) = ((fixed_mat.G A))^-1"
  unfolding fixed_mat.G_def by (force simp: transpose_def)

lemma G_transpose_trancl:
  "(fixed_mat.G (transpose A))^+ = ((fixed_mat.G A)^+)^-1"
  unfolding G_transpose trancl_converse by auto

locale pf_nonneg_mat = fixed_mat A for
  A :: "'a :: linordered_idom ^ 'n ^ 'n" +
  assumes non_neg_mat: "non_neg_mat A"
begin
lemma nonneg: "A $ i $ j \<ge> 0"
  using non_neg_mat unfolding non_neg_mat_def elements_mat_h_def by auto

lemma nonneg_matpow: "matpow A n $ i $ j \<ge> 0"
  by (induct n arbitrary: i j, insert nonneg,
    auto intro!: sum_nonneg simp: matrix_matrix_mult_def mat_def)

lemma G_relpow_matpow_pos: "(i,j) \<in> G ^^ n \<Longrightarrow> matpow A n $ i $ j > 0"
proof (induct n arbitrary: i j)
  case (0 i)
  thus ?case by (auto simp: mat_def)
next
  case (Suc n i j)
  from Suc(2) have "(i,j) \<in> G ^^ n O G"
    by (simp add: relpow_commute)
  then obtain k where
    ik: "A $ k $ j \<noteq> 0" and kj: "(i, k) \<in> G ^^ n" by (auto simp: G_def)
  from ik nonneg[of k j] have ik: "A $ k $ j > 0" by auto
  from Suc(1)[OF kj] have IH: "matpow A n $h i $h k > 0" .
  thus ?case using ik by (auto simp: nonneg_matpow nonneg matrix_matrix_mult_def
    intro!: sum_pos2[of _ k] mult_nonneg_nonneg)
qed

lemma matpow_mono: assumes B: "\<And> i j. B $ i $ j \<ge> A $ i $ j"
  shows "matpow B n $ i $ j \<ge> matpow A n $ i $ j"
proof (induct n arbitrary: i j)
  case (Suc n i j)
  thus ?case using B nonneg_matpow[of n] nonneg
    by (auto simp: matrix_matrix_mult_def intro!: sum_mono mult_mono')
qed simp

lemma matpow_sum_one_mono: "matpow (A + mat 1) (n + k) $ i $ j \<ge> matpow (A + mat 1) n $ i $ j"
proof (induct k)
  case (Suc k)
  have "(matpow (A + mat 1) (n + k) ** A) $h i $h j \<ge> 0" unfolding matrix_matrix_mult_def
    using order.trans[OF nonneg_matpow matpow_mono[of "A + mat 1" "n + k"]]
    by (auto intro!: sum_nonneg mult_nonneg_nonneg nonneg simp: mat_def)
  thus ?case using Suc by (simp add: matrix_add_ldistrib matrix_mul_rid)
qed simp

lemma G_relpow_matpow_pos_ge:
  assumes "(i,j) \<in> G ^^ m" "n \<ge> m"
  shows "matpow (A + mat 1) n $ i $ j > 0"
proof -
  from assms(2) obtain k where n: "n = m + k" using le_Suc_ex by blast
  have "0 < matpow A m $ i $ j" by (rule G_relpow_matpow_pos[OF assms(1)])
  also have "\<dots> \<le> matpow (A + mat 1) m $ i $ j"
    by (rule matpow_mono, auto simp: mat_def)
  also have "\<dots> \<le> matpow (A + mat 1) n $ i $ j" unfolding n using matpow_sum_one_mono .
  finally show ?thesis .
qed
end

locale perron_frobenius = pf_nonneg_mat A
  for A :: "real ^ 'n ^ 'n" +
  assumes irr: irreducible
begin

definition N where "N = (SOME N. \<forall> ij. \<exists> n \<le> N. ij \<in> G ^^ n)"

lemma N: "\<exists> n \<le> N. ij \<in> G ^^ n"
proof -
  {
    fix ij
    have "ij \<in> G^+" using irr[unfolded irreducible_def] by auto
    from this[unfolded trancl_power] have "\<exists> n. ij \<in> G ^^ n" by blast
  }
  hence "\<forall> ij. \<exists> n. ij \<in> G ^^ n" by auto
  from choice[OF this] obtain f where f: "\<And> ij. ij \<in> G ^^ (f ij)" by auto
  define N where N: "N = Max (range f)"
  {
    fix ij
    from f[of ij] have "ij \<in> G ^^ f ij" .
    moreover have "f ij \<le> N" unfolding N
      by (rule Max_ge, auto)
    ultimately have "\<exists> n \<le> N. ij \<in> G ^^ n" by blast
  } note main = this
  let ?P = "\<lambda> N. \<forall> ij. \<exists> n \<le> N. ij \<in> G ^^ n"
  from main have "?P N" by blast
  from someI[of ?P, OF this, folded N_def]
  show ?thesis by blast
qed

lemma irreducible_matpow_pos: assumes irreducible
  shows "matpow (A + mat 1) N $ i $ j > 0"
proof -
  from N obtain n where n: "n \<le> N" and reach: "(i,j) \<in> G ^^ n" by auto
  show ?thesis by (rule G_relpow_matpow_pos_ge[OF reach n])
qed

lemma pf_transpose: "perron_frobenius (transpose A)"
proof
  show "fixed_mat.irreducible (transpose A)"
    unfolding fixed_mat.irreducible_def G_transpose_trancl using irr[unfolded irreducible_def]
    by auto
qed (insert nonneg, auto simp: transpose_def non_neg_mat_def elements_mat_h_def)

abbreviation le_vec :: "real ^ 'n \<Rightarrow> real ^ 'n \<Rightarrow> bool" where
  "le_vec x y \<equiv> (\<forall> i. x $ i \<le> y $ i)"

abbreviation lt_vec :: "real ^ 'n \<Rightarrow> real ^ 'n \<Rightarrow> bool" where
  "lt_vec x y \<equiv> (\<forall> i. x $ i < y $ i)"

definition "A1n = matpow (A + mat 1) N"

lemmas A1n_pos = irreducible_matpow_pos[OF irr, folded A1n_def]

definition r :: "real ^ 'n \<Rightarrow> real" where
  "r x = Min { (A *v x) $ j / x $ j | j. x $ j \<noteq> 0 }"

definition X :: "(real ^ 'n )set" where
  "X = { x . le_vec 0 x \<and> x \<noteq> 0 }"

lemma nonneg_Ax: "x \<in> X \<Longrightarrow> le_vec 0 (A *v x)"
  unfolding X_def using nonneg
  by (auto simp: matrix_vector_mult_def intro!: sum_nonneg)

lemma A_nonzero_fixed_j: "\<exists> i. A $ i $ j \<noteq> 0"
proof -
  from irr[unfolded irreducible_def] have "(j,j) \<in> G^+" by auto
  then obtain i where "(i,j) \<in> G" by (cases, auto)
  hence Aij: "A $ i $ j \<noteq> 0" unfolding G_def by auto
  thus ?thesis ..
qed

lemma Ax_pos: assumes x: "lt_vec 0 x"
  shows "lt_vec 0 (A *v x)"
proof
  fix i
  from A_nonzero_fixed_i[of i] obtain j where "A $ i $ j \<noteq> 0" by auto
  with nonneg[of i j] have A: "A $ i $ j > 0" by simp
  from x have "x $ j \<ge> 0" for j by (auto simp: order.strict_iff_order)
  note nonneg = mult_nonneg_nonneg[OF nonneg[of i] this]
  have "(A *v x) $ i = (\<Sum>j\<in>UNIV. A $ i $ j * x $ j)"
    unfolding matrix_vector_mult_def by simp
  also have "\<dots> = A $ i $ j * x $ j + (\<Sum>j\<in>UNIV - {j}. A $ i $ j * x $ j)"
    by (subst sum.remove, auto)
  also have "\<dots> > 0 + 0"
    by (rule add_less_le_mono, insert A x[rule_format] nonneg,
    auto intro!: sum_nonneg mult_pos_pos)
  finally show "0 $ i < (A *v x) $ i" by simp
qed

lemma nonzero_Ax: assumes x: "x \<in> X"
  shows "A *v x \<noteq> 0"
proof
  assume 0: "A *v x = 0"
  from x[unfolded X_def] have x: "le_vec 0 x" "x \<noteq> 0" by auto
  from x(2) obtain j where xj: "x $ j \<noteq> 0"
    by (metis vec_eq_iff zero_index)
  from A_nonzero_fixed_j[of j]  obtain i where Aij: "A $ i $ j \<noteq> 0" by auto
  from arg_cong[OF 0, of "\<lambda> v. v $ i", unfolded matrix_vector_mult_def]
  have "0 = (\<Sum> k \<in> UNIV. A $h i $h k * x $h k)" by auto
  also have "\<dots> = A $h i $h j * x $h j + (\<Sum> k \<in> UNIV - {j}. A $h i $h k * x $h k)"
    by (subst sum.remove[of _ j], auto)
  also have "\<dots> > 0 + 0"
    by (rule add_less_le_mono, insert nonneg[of i] Aij x(1) xj,
    auto intro!: sum_nonneg mult_pos_pos simp: dual_order.not_eq_order_implies_strict)
  finally show False by simp
qed

lemma r_witness: assumes x: "x \<in> X"
  shows "\<exists> j. x $ j > 0 \<and> r x = (A *v x) $ j / x $ j"
proof -
  from x[unfolded X_def] have x: "le_vec 0 x" "x \<noteq> 0" by auto
  let ?A = "{ (A *v x) $ j / x $ j | j. x $ j \<noteq> 0 }"
  from x(2) obtain j where "x $ j \<noteq> 0"
    by (metis vec_eq_iff zero_index)
  hence empty: "?A \<noteq> {}" by auto
  from Min_in[OF _ this, folded r_def]
  obtain j where "x $ j \<noteq> 0" and rx: "r x = (A *v x) $ j / x $ j" by auto
  with x have "x $ j > 0" by (auto simp: dual_order.not_eq_order_implies_strict)
  with rx show ?thesis by auto
qed

lemma rx_nonneg: assumes x: "x \<in> X"
  shows "r x \<ge> 0"
proof -
  from x[unfolded X_def] have x: "le_vec 0 x" "x \<noteq> 0" by auto
  let ?A = "{ (A *v x) $ j / x $ j | j. x $ j \<noteq> 0 }"
  from r_witness[OF \<open>x \<in> X\<close>]
  have empty: "?A \<noteq> {}" by force
  show ?thesis unfolding r_def X_def
  proof (subst Min_ge_iff, force, use empty in force, intro ballI)
    fix y
    assume "y \<in> ?A"
    then obtain j where "y = (A *v x) $ j / x $ j" and "x $ j \<noteq> 0" by auto
    from nonneg_Ax[OF \<open>x \<in> X\<close>] this x
    show "0 \<le> y" by simp
  qed
qed

lemma rx_pos: assumes x: "lt_vec 0 x"
  shows "r x > 0"
proof -
  from Ax_pos[OF x] have lt: "lt_vec 0 (A *v x)" .
  from x have x': "x \<in> X" unfolding X_def order.strict_iff_order by auto
  let ?A = "{ (A *v x) $ j / x $ j | j. x $ j \<noteq> 0 }"
  from r_witness[OF \<open>x \<in> X\<close>]
  have empty: "?A \<noteq> {}" by force
  show ?thesis unfolding r_def X_def
  proof (subst Min_gr_iff, force, use empty in force, intro ballI)
    fix y
    assume "y \<in> ?A"
    then obtain j where "y = (A *v x) $ j / x $ j" and "x $ j \<noteq> 0" by auto
    from lt this x show "0 < y" by simp
  qed
qed

lemma rx_le_Ax: assumes x: "x \<in> X"
  shows "le_vec (r x *s x) (A *v x)"
proof (intro allI)
  fix i
  show "(r x *s x) $h i \<le> (A *v x) $h i"
  proof (cases "x $ i = 0")
    case True
    with nonneg_Ax[OF x] show ?thesis by auto
  next
    case False
    with x[unfolded X_def] have pos: "x $ i > 0"
      by (auto simp: dual_order.not_eq_order_implies_strict)
    from False have "(A *v x) $h i / x $ i \<in> { (A *v x) $ j / x $ j | j. x $ j \<noteq> 0 }" by auto
    hence "(A *v x) $h i / x $ i \<ge> r x" unfolding r_def by simp
    hence "x $ i * r x \<le> x $ i * ((A *v x) $h i / x $ i)" unfolding mult_le_cancel_left_pos[OF pos] .
    also have "\<dots> = (A *v x) $h i" using pos by simp
    finally show ?thesis by (simp add: ac_simps)
  qed
qed

lemma rho_le_x_Ax_imp_rho_le_rx: assumes x: "x \<in> X"
  and \<rho>: "le_vec (\<rho> *s x) (A *v x)"
shows "\<rho> \<le> r x"
proof -
  from r_witness[OF x] obtain j where
    rx: "r x = (A *v x) $ j / x $ j" and xj: "x $ j > 0" "x $ j \<ge> 0" by auto
  from divide_right_mono[OF \<rho>[rule_format, of j] xj(2)]
  show ?thesis unfolding rx using xj by simp
qed

lemma rx_Max: assumes x: "x \<in> X"
  shows "r x = Sup { \<rho> . le_vec (\<rho> *s x) (A *v x) }" (is "_ = Sup ?S")
proof -
  have "r x \<in> ?S" using rx_le_Ax[OF x] by auto
  moreover {
    fix y
    assume "y \<in> ?S"
    hence y: "le_vec (y *s x) (A *v x)" by auto
    from rho_le_x_Ax_imp_rho_le_rx[OF x this]
    have "y \<le> r x" .
  }
  ultimately show ?thesis by (metis (mono_tags, lifting) cSup_eq_maximum)
qed

lemma r_smult: assumes x: "x \<in> X"
  and a: "a > 0"
shows "r (a *s x) = r x"
  unfolding r_def
  by (rule arg_cong[of _ _ Min], unfold vector_smult_distrib, insert a, simp)

definition "X1 = (X \<inter> {x. norm x = 1})"

lemma bounded_X1: "bounded X1" unfolding bounded_iff X1_def by auto

lemma closed_X1: "closed X1"
proof -
  have X1: "X1 = {x. le_vec 0 x \<and> norm x = 1}"
    unfolding X1_def X_def by auto
  show ?thesis unfolding X1
    by (intro closed_Collect_conj closed_Collect_all  closed_Collect_le closed_Collect_eq,
      auto intro: continuous_intros)
qed

lemma compact_X1: "compact X1" using bounded_X1 closed_X1
  by (simp add: compact_eq_bounded_closed)

definition "pow_A_1 x = A1n *v x"

lemma continuous_pow_A_1: "continuous_on R pow_A_1"
  unfolding pow_A_1_def continuous_on
  by (auto intro: tendsto_intros)

definition "Y = pow_A_1 ` X1"

lemma compact_Y: "compact Y"
  unfolding Y_def using compact_X1 continuous_pow_A_1[of X1]
  by (metis compact_continuous_image)

lemma Y_pos: assumes y: "y \<in> Y"
  shows "y $ i > 0"
  using Y_pos_main[of y i] y unfolding Y_def X1_def by auto

lemma Y_nonzero: assumes y: "y \<in> Y"
  shows "y $ i \<noteq> 0"
  using Y_pos[OF y, of i] by auto

definition r' :: "real ^ 'n \<Rightarrow> real" where
  "r' x = Min (range (\<lambda> j. (A *v x) $ j / x $ j))"

lemma r'_r: assumes x: "x \<in> Y" shows "r' x = r x"
  unfolding r'_def r_def
proof (rule arg_cong[of _ _ Min])
  have "range (\<lambda>j. (A *v x) $ j / x $ j) \<subseteq> {(A *v x) $ j / x $ j |j. x $ j \<noteq> 0}" (is "?L \<subseteq> ?R")
  proof
    fix y
    assume "y \<in> ?L"
    then obtain j where "y = (A *v x) $ j / x $ j" by auto
    with Y_pos[OF x, of j] show "y \<in> ?R" by auto
  qed
  moreover have "?L \<supseteq> ?R" by auto
  ultimately show "?L = ?R" by blast
qed

lemma continuous_Y_r: "continuous_on Y r"
proof -
  have *: "(\<forall> y \<in> Y. P y (r y)) = (\<forall> y \<in> Y. P y (r' y))" for P using r'_r by auto
  have "continuous_on Y r = continuous_on Y r'"
    by (rule continuous_on_cong[OF refl r'_r[symmetric]])
  also have \<dots>
    unfolding continuous_on r'_def using Y_nonzero
    by (auto intro!: tendsto_Min tendsto_intros)
  finally show ?thesis .
qed

lemma X1_nonempty: "X1 \<noteq> {}"
proof -
  define x where "x = ((\<chi> i. if i = undefined then 1 else 0) :: real ^ 'n)"
  {
    assume "x = 0"
    from arg_cong[OF this, of "\<lambda> x. x $ undefined"] have False unfolding x_def by auto
  }
  hence x: "x \<noteq> 0" by auto
  moreover have "le_vec 0 x" unfolding x_def by auto
  moreover have "norm x = 1" unfolding norm_vec_def L2_set_def
    by (auto, subst sum.remove[of _ undefined], auto simp: x_def)
  ultimately show ?thesis unfolding X1_def X_def by auto
qed

lemma Y_nonempty: "Y \<noteq> {}"
  unfolding Y_def using X1_nonempty by auto

definition z where "z = (SOME z. z \<in> Y \<and> (\<forall> y \<in> Y. r y \<le> r z))"

abbreviation "sr \<equiv> r z"

lemma z: "z \<in> Y" and sr_max_Y: "\<And> y. y \<in> Y \<Longrightarrow> r y \<le> sr"
proof -
  let ?P = "\<lambda> z. z \<in> Y \<and> (\<forall> y \<in> Y. r y \<le> r z)"
  from continuous_attains_sup[OF compact_Y Y_nonempty continuous_Y_r]
  obtain y where "?P y" by blast
  from someI[of ?P, OF this, folded z_def]
  show "z \<in> Y" "\<And> y. y \<in> Y \<Longrightarrow> r y \<le> r z" by blast+
qed

lemma Y_subset_X: "Y \<subseteq> X"
proof
  fix y
  assume "y \<in> Y"
  from Y_pos[OF this] show "y \<in> X" unfolding X_def
    by (auto simp: order.strict_iff_order)
qed

lemma zX: "z \<in> X"
  using z(1) Y_subset_X by auto

lemma le_vec_mono_left: assumes B: "\<And> i j. B $ i $ j \<ge> 0"
  and "le_vec x y"
shows "le_vec (B *v x) (B *v y)"
proof (intro allI)
  fix i
  show "(B *v x) $ i \<le> (B *v y) $ i" unfolding matrix_vector_mult_def using B[of i] assms(2)
    by (auto intro!: sum_mono mult_left_mono)
qed

lemma matpow_1_commute: "matpow (A + mat 1) n ** A = A ** matpow (A + mat 1) n"
  by (induct n, auto simp: matrix_add_rdistrib matrix_add_ldistrib matrix_mul_rid matrix_mul_lid
  matrix_mul_assoc[symmetric])

lemma A1n_commute: "A1n ** A = A ** A1n"
  unfolding A1n_def by (rule matpow_1_commute)

lemma le_vec_pow_A_1: assumes le: "le_vec (rho *s x) (A *v x)"
  shows "le_vec (rho *s pow_A_1 x) (A *v pow_A_1 x)"
proof -
  have "A1n $ i $ j \<ge> 0" for i j using A1n_pos[of i j] by auto
  from le_vec_mono_left[OF this le]
  have "le_vec (A1n *v (rho *s x)) (A1n *v (A *v x))" .
  also have "A1n *v (A *v x) = (A1n ** A) *v x" by (simp add: matrix_vector_mul_assoc)
  also have "\<dots> = A *v (A1n *v x)" unfolding A1n_commute by (simp add: matrix_vector_mul_assoc)
  also have "\<dots> = A *v (pow_A_1 x)" unfolding pow_A_1_def ..
  also have "A1n *v (rho *s x) = rho *s (A1n *v x)" unfolding vector_smult_distrib ..
  also have "\<dots> = rho *s pow_A_1 x" unfolding pow_A_1_def ..
  finally show "le_vec (rho *s pow_A_1 x) (A *v pow_A_1 x)" .
qed

lemma r_pow_A_1: assumes x: "x \<in> X"
  shows "r x \<le> r (pow_A_1 x)"
proof -
  let ?y = "pow_A_1 x"
  have "?y \<in> pow_A_1 ` X" using x by auto
  from Y_pos_main[OF this]
  have y: "?y \<in> X" unfolding X_def by (auto simp: order.strict_iff_order)
  let ?A = "{\<rho>. le_vec (\<rho> *s x) (A *v x)}"
  let ?B = "{\<rho>. le_vec (\<rho> *s pow_A_1 x) (A *v pow_A_1 x)}"
  show ?thesis unfolding rx_Max[OF x] rx_Max[OF y]
  proof (rule cSup_mono)
    show "bdd_above ?B" using rho_le_x_Ax_imp_rho_le_rx[OF y] by fast
    show "?A \<noteq> {}" using rx_le_Ax[OF x] by auto
    fix rho
    assume "rho \<in> ?A"
    hence "le_vec (rho *s x) (A *v x)" by auto
    from le_vec_pow_A_1[OF this] have "rho \<in> ?B" by auto
    thus "\<exists> rho' \<in> ?B. rho \<le> rho'" by auto
  qed
qed

lemma sr_max: assumes x: "x \<in> X"
  shows "r x \<le> sr"
proof -
  let ?n = "norm x"
  define x' where "x' = inverse ?n *s x"
  from x[unfolded X_def] have x0: "x \<noteq> 0" by auto
  hence n: "?n > 0" by auto
  have x': "x' \<in> X1" "x' \<in> X" using x n unfolding X1_def X_def x'_def by (auto simp: norm_smult)
  have id: "r x = r x'" unfolding x'_def
    by (rule sym, rule r_smult[OF x], insert n, auto)
  define y where "y = pow_A_1 x'"
  from x' have y: "y \<in> Y" unfolding Y_def y_def by auto
  note id
  also have "r x' \<le> r y" using r_pow_A_1[OF x'(2)] unfolding y_def .
  also have "\<dots> \<le> r z" using sr_max_Y[OF y] .
  finally show "r x \<le> r z" .
qed

lemma z_pos: "z $ i > 0"
  using Y_pos[OF z(1)] by auto

lemma sr_pos: "sr > 0"
  by (rule rx_pos, insert z_pos, auto)

context fixes u
  assumes u: "u \<in> X" and ru: "r u = sr"
begin

lemma sr_imp_eigen_vector_main: "sr *s u = A *v u"
proof (rule ccontr)
  assume *: "sr *s u \<noteq> A *v u"
  let ?x = "A *v u - sr *s u"
  from * have 0: "?x \<noteq> 0" by auto
  let ?y = "pow_A_1 u"
  have "le_vec (sr *s u) (A *v u)" using rx_le_Ax[OF u] unfolding ru .
  hence le: "le_vec 0 ?x" by auto
  from 0 le have x: "?x \<in> X" unfolding X_def by auto
  have y_pos: "lt_vec 0 ?y" using Y_pos_main[of ?y] u by auto
  hence y: "?y \<in> X" unfolding X_def by (auto simp: order.strict_iff_order)
  from Y_pos_main[of "pow_A_1 ?x"] x
  have "lt_vec 0 (pow_A_1 ?x)" by auto
  hence lt: "lt_vec (sr *s ?y) (A *v ?y)" unfolding pow_A_1_def matrix_vector_right_distrib_diff
    matrix_vector_mul_assoc A1n_commute vector_smult_distrib by simp
  let ?f = "(\<lambda> i. (A *v ?y - sr *s ?y) $ i / ?y $ i)"
  let ?U = "UNIV :: 'n set"
  define eps where "eps = Min (?f ` ?U)"
  have U: "finite (?f ` ?U)" "?f ` ?U \<noteq> {}" by auto
  have eps: "eps > 0" unfolding eps_def Min_gr_iff[OF U]
    using lt sr_pos y_pos by auto
  have le: "le_vec ((sr + eps) *s ?y) (A *v ?y)"
  proof
    fix i
    have "((sr + eps) *s ?y) $ i = sr * ?y $ i + eps * ?y $ i"
      by (simp add: comm_semiring_class.distrib)
    also have "\<dots> \<le> sr * ?y $ i + ?f i * ?y $ i"
    proof (rule add_left_mono[OF mult_right_mono])
      show "0 \<le> ?y $ i" using y_pos[rule_format, of i] by auto
      show "eps \<le> ?f i" unfolding eps_def by (rule Min_le, auto)
    qed
    also have "\<dots> = (A *v ?y) $ i" using sr_pos y_pos[rule_format, of i]
      by simp
    finally
    show "((sr + eps) *s ?y) $ i \<le> (A *v ?y) $ i" .
  qed
  from rho_le_x_Ax_imp_rho_le_rx[OF y le]
  have "r ?y \<ge> sr + eps" .
  with sr_max[OF y] eps show False by auto
qed

lemma sr_imp_eigen_vector: "eigen_vector A u sr"
  unfolding eigen_vector_def sr_imp_eigen_vector_main using u unfolding X_def by auto

lemma sr_u_pos: "lt_vec 0 u"
proof -
  let ?y = "pow_A_1 u"
  define n where "n = N"
  define c where "c = (sr + 1)^N"
  have c: "c > 0" using sr_pos unfolding c_def by auto
  have "lt_vec 0 ?y" using Y_pos_main[of ?y] u by auto
  also have "?y = A1n *v u" unfolding pow_A_1_def ..
  also have "\<dots> = c *s u" unfolding c_def A1n_def n_def[symmetric]
  proof (induct n)
    case (Suc n)
    then show ?case
      by (simp add: matrix_vector_mul_assoc[symmetric] algebra_simps vec.scale
          sr_imp_eigen_vector_main[symmetric])
  qed auto
  finally have lt: "lt_vec 0 (c *s u)" .
  have "0 < u $ i" for i using lt[rule_format, of i] c by simp (metis zero_less_mult_pos)
  thus "lt_vec 0 u" by simp
qed
end

lemma eigen_vector_z_sr: "eigen_vector A z sr"
  using sr_imp_eigen_vector[OF zX refl] by auto

lemma eigen_value_sr: "eigen_value A sr"
  using eigen_vector_z_sr unfolding eigen_value_def by auto

abbreviation "c \<equiv> complex_of_real"
abbreviation "cA \<equiv> map_matrix c A"
abbreviation "norm_v \<equiv> map_vector (norm :: complex \<Rightarrow> real)"

lemma norm_v_ge_0: "le_vec 0 (norm_v v)" by (auto simp: map_vector_def)
lemma norm_v_eq_0: "norm_v v = 0 \<longleftrightarrow> v = 0" by (auto simp: map_vector_def vec_eq_iff)

lemma cA_index: "cA $ i $ j = c (A $ i $ j)"
  unfolding map_matrix_def map_vector_def by simp

lemma norm_cA[simp]: "norm (cA $ i $ j) = A $ i $ j"
  using nonneg[of i j] by (simp add: cA_index)

context fixes \<alpha> v
  assumes ev: "eigen_vector cA v \<alpha>"
begin

lemma evD: "\<alpha> *s v = cA *v v" "v \<noteq> 0"
  using ev[unfolded eigen_vector_def] by auto

lemma ev_alpha_norm_v: "norm_v (\<alpha> *s v) = (norm \<alpha> *s norm_v v)"
  by (auto simp: map_vector_def norm_mult vec_eq_iff)

lemma ev_A_norm_v: "norm_v (cA *v v) $ j \<le> (A *v norm_v v) $ j"
proof -
  have "norm_v (cA *v v) $ j = norm (\<Sum>i\<in>UNIV. cA $ j $ i * v $ i)"
    unfolding map_vector_def by (simp add: matrix_vector_mult_def)
  also have "\<dots> \<le> (\<Sum>i\<in>UNIV. norm (cA $ j $ i * v $ i))" by (rule norm_sum)
  also have "\<dots> = (\<Sum>i\<in>UNIV. A $ j $ i * norm_v v $ i)"
    by (rule sum.cong[OF refl], auto simp: norm_mult map_vector_def)
  also have "\<dots> = (A *v norm_v v) $ j" by (simp add: matrix_vector_mult_def)
  finally show ?thesis .
qed

lemma ev_le_vec: "le_vec (norm \<alpha> *s norm_v v) (A *v norm_v v)"
  using arg_cong[OF evD(1), of norm_v, unfolded ev_alpha_norm_v] ev_A_norm_v by auto

lemma norm_v_X: "norm_v v \<in> X"
  using norm_v_ge_0[of v] evD(2) norm_v_eq_0[of v] unfolding X_def by auto

lemma ev_inequalities: "norm \<alpha> \<le> r (norm_v v)" "r (norm_v v) \<le> sr"
proof -
  have v: "norm_v v \<in> X" by (rule norm_v_X)
  from rho_le_x_Ax_imp_rho_le_rx[OF v ev_le_vec]
  show "norm \<alpha> \<le> r (norm_v v)" .
  from sr_max[OF v]
  show "r (norm_v v) \<le> sr" .
qed

lemma eigen_vector_norm_sr: "norm \<alpha> \<le> sr" using ev_inequalities by auto
end

lemma eigen_value_norm_sr: assumes "eigen_value cA \<alpha>"
  shows "norm \<alpha> \<le> sr"
  using eigen_vector_norm_sr[of _ \<alpha>] assms unfolding eigen_value_def by auto

lemma eigen_vector_z_sr_c: "eigen_vector cA (map_vector c z) (c sr)"
  unfolding of_real_hom.eigen_vector_hom by (rule eigen_vector_z_sr)

lemma eigen_value_sr_c: "eigen_value cA (c sr)"
  using eigen_vector_z_sr_c unfolding eigen_value_def by auto

definition "w = perron_frobenius.z (transpose A)"

lemma c_cmod_id: "a \<in> \<real> \<Longrightarrow> Re a \<ge> 0 \<Longrightarrow> c (cmod a) = a" by (auto simp: Reals_def)

lemma pos_rowvector_mult_0: assumes lt: "lt_vec 0 x"
  and 0: "(rowvector x :: real ^ 'n ^ 'n) *v y = 0" (is "?x *v _ = 0") and le: "le_vec 0 y"
shows "y = 0"
proof -
  {
    fix i
    assume "y $ i \<noteq> 0"
    with le have yi: "y $ i > 0" by (auto simp: order.strict_iff_order)
    have "0 = (?x *v y) $ i" unfolding 0 by simp
    also have "\<dots> = (\<Sum>j\<in>UNIV. x $ j * y $ j)"
      unfolding rowvector_def matrix_vector_mult_def by simp
    also have "\<dots> > 0"
      by (rule sum_pos2[of _ i], insert yi lt le, auto intro!: mult_nonneg_nonneg
        simp: order.strict_iff_order)
    finally have False by simp
  }
  thus ?thesis by (auto simp: vec_eq_iff)
qed

lemma pos_matrix_mult_0: assumes le: "\<And> i j. B $ i $ j \<ge> 0"
  and lt: "lt_vec 0 x"
  and 0: "B *v x = 0"
shows "B = 0"
proof -
  {
    fix i j
    assume "B $ i $ j \<noteq> 0"
    with le have gt: "B $ i $ j > 0" by (auto simp: order.strict_iff_order)
    have "0 = (B *v x) $ i" unfolding 0 by simp
    also have "\<dots> = (\<Sum>j\<in>UNIV. B $ i $ j * x $ j)"
      unfolding matrix_vector_mult_def by simp
    also have "\<dots> > 0"
      by (rule sum_pos2[of _ j], insert gt lt le, auto intro!: mult_nonneg_nonneg
        simp: order.strict_iff_order)
    finally have False by simp
  }
  thus "B = 0" unfolding vec_eq_iff by auto
qed

lemma eigen_value_smaller_matrix: assumes B: "\<And> i j. 0 \<le> B $ i $ j \<and> B $ i $ j \<le> A $ i $ j"
  and AB: "A \<noteq> B"
  and ev: "eigen_value (map_matrix c B) sigma"
shows "cmod sigma < sr"
proof -
  let ?B = "map_matrix c B"
  let ?sr = "spectral_radius ?B"
  define \<sigma> where "\<sigma> = ?sr"
  have "real_non_neg_mat ?B" unfolding real_non_neg_mat_def elements_mat_h_def
    by (auto simp: map_matrix_def map_vector_def B)
  from perron_frobenius[OF this, folded \<sigma>_def] obtain x where ev_sr: "eigen_vector ?B x (c \<sigma>)"
    and rnn: "real_non_neg_vec x" by auto
  define y where "y = norm_v x"
  from rnn have xy: "x = map_vector c y"
    unfolding real_non_neg_vec_def vec_elements_h_def y_def
    by (auto simp: map_vector_def vec_eq_iff c_cmod_id)
  from spectral_radius_max[OF ev, folded \<sigma>_def] have sigma_sigma: "cmod sigma \<le> \<sigma>" .
  from ev_sr[unfolded xy of_real_hom.eigen_vector_hom]
  have ev_B: "eigen_vector B y \<sigma>" .
  from ev_B[unfolded eigen_vector_def] have ev_B': "B *v y = \<sigma> *s y" by auto
  have ypos: "y $ i \<ge> 0" for i unfolding y_def by (auto simp: map_vector_def)
  from ev_B this have y: "y \<in> X" unfolding eigen_vector_def X_def by auto

  have BA: "(B *v y) $ i \<le> (A *v y) $ i" for i
    unfolding matrix_vector_mult_def vec_lambda_beta
    by (rule sum_mono, rule mult_right_mono, insert B ypos, auto)
  hence le_vec: "le_vec (\<sigma> *s y) (A *v y)" unfolding ev_B' by auto
  from rho_le_x_Ax_imp_rho_le_rx[OF y le_vec]
  have "\<sigma> \<le> r y" by auto
  also have "\<dots> \<le> sr" using y by (rule sr_max)
  finally have sig_le_sr: "\<sigma> \<le> sr" .
  {
    assume "\<sigma> = sr"
    hence r_sr: "r y = sr" and sr_sig: "sr = \<sigma>" using \<open>\<sigma> \<le> r y\<close> \<open>r y \<le> sr\<close> by auto
    from sr_u_pos[OF y r_sr] have pos: "lt_vec 0 y" .
    from sr_imp_eigen_vector[OF y r_sr] have ev': "eigen_vector A y sr" .
    have "(A - B) *v y = A *v y - B *v y" unfolding matrix_vector_mult_def
      by (auto simp: vec_eq_iff field_simps sum_subtractf)
    also have "A *v y = sr *s y" using ev'[unfolded eigen_vector_def] by auto
    also have "B *v y = sr *s y" unfolding ev_B' sr_sig ..
    finally have id: "(A - B) *v y = 0" by simp
    from pos_matrix_mult_0[OF _ pos id] assms(1-2) have False by auto
  }
  with sig_le_sr sigma_sigma show ?thesis by argo
qed

lemma charpoly_erase_mat_sr: "0 < poly (charpoly (erase_mat A i i)) sr"
proof -
  let ?A = "erase_mat A i i"
  let ?pos = "poly (charpoly ?A) sr"
  {
    from A_nonzero_fixed_j[of i] obtain k where "A $ k $ i \<noteq> 0" by auto
    assume "A = ?A"
    hence "A $ k $ i = ?A $ k $ i" by simp
    also have "?A $ k $ i = 0" by (auto simp: erase_mat_def)
    also have "A $ k $ i \<noteq> 0" by fact
    finally have False by simp
  }
  hence AA: "A \<noteq> ?A" by auto
  have le: "0 \<le> ?A $ i $ j \<and> ?A $ i $ j \<le> A $ i $ j" for i j
    by (auto simp: erase_mat_def nonneg)
  note ev_small = eigen_value_smaller_matrix[OF le AA]
  {
    fix rho :: real
    assume "eigen_value ?A rho"
    hence ev: "eigen_value (map_matrix c ?A) (c rho)"
      unfolding eigen_value_def using of_real_hom.eigen_vector_hom[of ?A _ rho] by auto
    from ev_small[OF this] have "abs rho < sr" by auto
  } note ev_small_real = this
  have pos0: "?pos \<noteq> 0"
    using ev_small_real[of sr] by (auto simp: eigen_value_root_charpoly)
  {
    define p where "p = charpoly ?A"
    assume pos: "?pos < 0"
    hence neg: "poly p sr < 0" unfolding p_def by auto
    from degree_monic_charpoly[of ?A] have mon: "monic p" and deg: "degree p \<noteq> 0" unfolding p_def by auto
    let ?f = "poly p"
    have cont: "continuous_on {a..b} ?f" for a b by (auto intro: continuous_intros)
    from pos have le: "?f sr \<le> 0" by (auto simp: p_def)
    from mon have lc: "lead_coeff p > 0" by auto
    from poly_pinfty_ge[OF this deg, of 0] obtain z where lez: "\<And> x. z \<le> x \<Longrightarrow> 0 \<le> ?f x" by auto
    define y where "y = max z sr"
    have yr: "y \<ge> sr" and "y \<ge> z" unfolding y_def by auto
    from lez[OF this(2)] have y0: "?f y \<ge> 0" .
    from IVT'[of ?f, OF le y0 yr cont] obtain x where ge: "x \<ge> sr" and rt: "?f x = 0"
      unfolding p_def by auto
    hence "eigen_value ?A x" unfolding p_def by (simp add: eigen_value_root_charpoly)
    from ev_small_real[OF this] ge have False by auto
  }
  with pos0 show ?thesis by argo
qed

lemma multiplicity_sr_1: "order sr (charpoly A) = 1"
proof -
  {
    assume "poly (pderiv (charpoly A)) sr = 0"
    hence "0 = poly (monom 1 1 * pderiv (charpoly A)) sr" by simp
    also have "\<dots> = sum (\<lambda> i. poly (charpoly (erase_mat A i i)) sr) UNIV"
      unfolding pderiv_char_poly_erase_mat poly_sum ..
    also have "\<dots> > 0"
      by (rule sum_pos, (force simp: charpoly_erase_mat_sr)+)
    finally have False by simp
  }
  hence nZ: "poly (pderiv (charpoly A)) sr \<noteq> 0" and nZ': "pderiv (charpoly A) \<noteq> 0" by auto
  from eigen_vector_z_sr have "eigen_value A sr" unfolding eigen_value_def ..
  from this[unfolded eigen_value_root_charpoly]
  have "poly (charpoly A) sr = 0" .
  hence "order sr (charpoly A) \<noteq> 0" unfolding order_root using nZ' by auto
  from order_pderiv[OF nZ' this] order_0I[OF nZ]
  show ?thesis by simp
qed

lemma sr_spectral_radius: "sr = spectral_radius cA"
proof -
  from eigen_vector_z_sr_c have "eigen_value cA (c sr)"
    unfolding eigen_value_def by auto
  from spectral_radius_max[OF this]
  have sr: "sr \<le> spectral_radius cA" by auto
  with spectral_radius_ev[of cA] eigen_vector_norm_sr
  show ?thesis by force
qed

lemma le_vec_A_mu: assumes y: "y \<in> X" and le: "le_vec (A *v y) (mu *s y)"
  shows "sr \<le> mu" "lt_vec 0 y"
  "mu = sr \<or> A *v y = mu *s y \<Longrightarrow> mu = sr \<and> A *v y = mu *s y"
proof -
  let ?w = "rowvector w"
  let ?w' = "columnvector w"
  have "?w ** A = transpose (transpose (?w ** A))"
    unfolding transpose_transpose by simp
  also have "transpose (?w ** A) = transpose A ** transpose ?w"
    by (rule matrix_transpose_mul)
  also have "transpose ?w = columnvector w" by (rule transpose_rowvector)
  also have "transpose A ** \<dots> = columnvector (transpose A *v w)"
    unfolding dot_rowvector_columnvector[symmetric] ..
  also have "transpose A *v w = sr *s w" unfolding w by simp
  also have "transpose (columnvector \<dots>) = rowvector (sr *s w)"
    unfolding transpose_def columnvector_def rowvector_def vector_scalar_mult_def by auto
  finally have 1: "?w ** A = rowvector (sr *s w)" .
  have "sr *s (?w *v y) = ?w ** A *v y" unfolding 1
    by (auto simp: rowvector_def vector_scalar_mult_def matrix_vector_mult_def vec_eq_iff
       sum_distrib_left mult.assoc)
  also have "\<dots> = ?w *v (A *v y)" by (simp add: matrix_vector_mul_assoc)
  finally have eq1: "sr *s (rowvector w *v y) = rowvector w *v (A *v y)" .
  have "le_vec (rowvector w *v (A *v y)) (?w *v (mu *s y))"
    by (rule le_vec_mono_left[OF _ le], insert w(2), auto simp: rowvector_def order.strict_iff_order)
  also have "?w *v (mu *s y) = mu *s (?w *v y)" by (simp add: algebra_simps vec.scale)
  finally have le1: "le_vec (rowvector w *v (A *v y)) (mu *s (?w *v y))" .
  from le1[unfolded eq1[symmetric]]
  have 2: "le_vec (sr *s (?w *v y)) (mu *s (?w *v y))" .
  {
    from y obtain i where yi: "y $ i > 0" and y: "\<And> j. y $ j \<ge> 0" unfolding X_def
      by (auto simp: order.strict_iff_order vec_eq_iff)
    from w(2) have wi: "w $ i > 0" and w: "\<And> j. w $ j \<ge> 0"
      by (auto simp: order.strict_iff_order)
    have "(?w *v y) $ i > 0" using yi y wi w
      by (auto simp: matrix_vector_mult_def rowvector_def
        intro!: sum_pos2[of _ i] mult_nonneg_nonneg)
    moreover from 2[rule_format, of i] have "sr * (?w *v y) $ i \<le> mu * (?w *v y) $ i" by simp
    ultimately have "sr \<le> mu" by simp
  }
  thus *: "sr \<le> mu" .
  define cc where "cc = (mu + 1)^ N"
  define n where "n = N"
  from * sr_pos have mu: "mu \<ge> 0" "mu > 0" by auto
  hence cc: "cc > 0" unfolding cc_def by simp
  from y have "pow_A_1 y \<in> pow_A_1 ` X" by auto
  from Y_pos_main[OF this] have lt: "0 < (A1n *v y) $ i" for i by (simp add: pow_A_1_def)
  have le: "le_vec (A1n *v y) (cc *s y)" unfolding cc_def A1n_def n_def[symmetric]
  proof (induct n)
    case (Suc n)
    let ?An = "matpow (A + mat 1) n"
    let ?mu = "(mu + 1)"
    have id': "matpow (A + mat 1) (Suc n) *v y = A *v (?An *v y) + ?An *v y" (is "?a = ?b + ?c")
      by (simp add: matrix_add_ldistrib matrix_mul_rid matrix_add_vect_distrib matpow_1_commute
       matrix_vector_mul_assoc[symmetric])
    have "le_vec ?b (?mu^n *s (A *v y))"
      using le_vec_mono_left[OF nonneg Suc] by (simp add: algebra_simps vec.scale)
    moreover have "le_vec (?mu^n *s (A *v y)) (?mu^n *s (mu *s y))"
      using le mu by auto
    moreover have id: "?mu^n *s (mu *s y) = (?mu^n * mu) *s y" by simp
    from le_vec_trans[OF calculation[unfolded id]]
    have le1: "le_vec ?b ((?mu^n * mu) *s y)" .
    from Suc have le2: "le_vec ?c ((mu + 1) ^ n *s y)" .
    have le: "le_vec ?a ((?mu^n * mu) *s y + ?mu^n *s y)"
      unfolding id' using add_mono[OF le1[rule_format] le2[rule_format]] by auto
    have id'': "(?mu^n * mu) *s y + ?mu^n *s y = ?mu^Suc n *s y" by (simp add: algebra_simps)
    show ?case using le unfolding id'' .
  qed (simp add: matrix_vector_mul_lid)
  have lt: "0 < cc * y $ i" for i using lt[of i] le[rule_format, of i] by auto
  have "y $ i > 0" for i using lt[of i] cc by (rule zero_less_mult_pos)
  thus "lt_vec 0 y" by auto
  assume **: "mu = sr \<or> A *v y = mu *s y"
  {
    assume "A *v y = mu *s y"
    with y have "eigen_vector A y mu" unfolding X_def eigen_vector_def by auto
    hence "eigen_vector cA (map_vector c y) (c mu)" unfolding of_real_hom.eigen_vector_hom .
    from eigen_vector_norm_sr[OF this] * have "mu = sr" by auto
  }
  with ** have mu_sr: "mu = sr" by auto
  from eq1[folded vector_smult_distrib]
  have 0: "?w *v (sr *s y - A *v y) = 0"
    unfolding matrix_vector_right_distrib_diff by simp
  have le0: "le_vec 0 (sr *s y - A *v y)" using assms(2)[unfolded mu_sr] by auto
  have "sr *s y - A *v y = 0" using pos_rowvector_mult_0[OF w(2) 0 le0] .
  hence ev_y: "A *v y = sr *s y" by auto
  show "mu = sr \<and> A *v y = mu *s y" using ev_y mu_sr by auto
qed

lemma nonnegative_eigenvector_has_ev_sr: assumes "eigen_vector A v mu" and le: "le_vec 0 v"
  shows "mu = sr"
proof -
  from assms(1)[unfolded eigen_vector_def] have v: "v \<noteq> 0" and ev: "A *v v = mu *s v" by auto
  from le v have v: "v \<in> X" unfolding X_def by auto
  from ev have "le_vec (A *v v) (mu *s v)" by auto
  from le_vec_A_mu[OF v this] ev show ?thesis by auto
qed

lemma similar_matrix_rotation: assumes ev: "eigen_value cA \<alpha>" and \<alpha>: "cmod \<alpha> = sr"
  shows "similar_matrix (cis (arg \<alpha>) *k cA) cA"
proof -
  from ev obtain y where ev: "eigen_vector cA y \<alpha>" unfolding eigen_value_def by auto
  let ?y = "norm_v y"
  note maps = map_vector_def map_matrix_def
  define yp where "yp = norm_v y"
  let ?yp = "map_vector c yp"
  have yp: "yp \<in> X" unfolding yp_def by (rule norm_v_X[OF ev])
  from ev[unfolded eigen_vector_def] have ev_y: "cA *v y = \<alpha> *s y" by auto
  from ev_le_vec[OF ev, unfolded \<alpha>, folded yp_def]
  have 1: "le_vec (sr *s yp) (A *v yp)" by simp
  from rho_le_x_Ax_imp_rho_le_rx[OF yp 1] have "sr \<le> r yp" by auto
  with ev_inequalities[OF ev, folded yp_def]
  have 2: "r yp = sr" by auto
  have ev_yp: "A *v yp = sr *s yp"
    and pos_yp: "lt_vec 0 yp"
    using sr_imp_eigen_vector_main[OF yp 2] sr_u_pos[OF yp 2] by auto
  define D where "D = diagvector (\<lambda> j. cis (arg (y $ j)))"
  define inv_D where "inv_D = diagvector (\<lambda> j. cis (- arg (y $ j)))"
  have DD: "inv_D ** D = mat 1" "D ** inv_D = mat 1" unfolding D_def inv_D_def
    by (auto simp add: diagvector_eq_mat cis_mult)
  {
    fix i
    have "(D *v ?yp) $ i = cis (arg (y $ i)) * c (cmod (y $ i))"
      unfolding D_def yp_def by (simp add: maps)
    also have "\<dots> = y $ i" by (simp add: cis_mult_cmod_id)
    also note calculation
  }
  hence y_D_yp: "y = D *v ?yp" by (auto simp: vec_eq_iff)
  define \<phi> where "\<phi> = arg \<alpha>"
  let ?\<phi> = "cis (- \<phi>)"
  have [simp]: "cis (- \<phi>) * rcis sr \<phi> = sr" unfolding cis_rcis_eq rcis_mult by simp
  have \<alpha>: "\<alpha> = rcis sr \<phi>" unfolding \<phi>_def \<alpha>[symmetric] rcis_cmod_arg ..
  define F where "F = ?\<phi> *k (inv_D ** cA ** D)"
  have "cA *v (D *v ?yp) = \<alpha> *s y" unfolding y_D_yp[symmetric] ev_y by simp
  also have "inv_D *v \<dots> = \<alpha> *s ?yp"
    unfolding vector_smult_distrib y_D_yp matrix_vector_mul_assoc DD matrix_vector_mul_lid ..
  also have "?\<phi> *s \<dots> = sr *s ?yp" unfolding \<alpha> by simp
  also have "\<dots> = map_vector c (sr *s yp)" unfolding vec_eq_iff by (auto simp: maps)
  also have "\<dots> = cA *v ?yp" unfolding ev_yp[symmetric] by (auto simp: maps matrix_vector_mult_def)
  finally have F: "F *v ?yp = cA *v ?yp" unfolding F_def matrix_scalar_vector_ac[symmetric]
    unfolding matrix_vector_mul_assoc[symmetric] vector_smult_distrib .
  have prod: "inv_D ** cA ** D = (\<chi> i j. cis (- arg (y $ i)) * cA $ i $ j * cis (arg (y $ j)))"
    unfolding inv_D_def D_def diagvector_mult_right diagvector_mult_left by simp
  {
    fix i j
    have "cmod (F $ i $ j) = cmod (?\<phi> * cA $h i $h j * (cis (- arg (y $h i)) * cis (arg (y $h j))))"
      unfolding F_def prod vec_lambda_beta matrix_scalar_mult_def
      by (simp only: ac_simps)
    also have "\<dots> = A $ i $ j" unfolding cis_mult unfolding norm_mult by simp
    also note calculation
  }
  hence FA: "map_matrix norm F = A" unfolding maps by auto
  let ?F = "map_matrix c (map_matrix norm F)"
  let ?G = "?F - F"
  let ?Re = "map_matrix Re"
  from F[folded FA] have 0: "?G *v ?yp = 0" unfolding matrix_diff_vect_distrib by simp
  have "?Re ?G *v yp = map_vector Re (?G *v ?yp)"
    unfolding maps matrix_vector_mult_def vec_lambda_beta Re_sum by auto
  also have "\<dots> = 0" unfolding 0 by (simp add: vec_eq_iff maps)
  finally have 0: "?Re ?G *v yp = 0" .
  have "?Re ?G = 0"
    by (rule pos_matrix_mult_0[OF _ pos_yp 0], auto simp: maps complex_Re_le_cmod)
  hence "?F = F" by (auto simp: maps vec_eq_iff cmod_eq_Re)
  with FA have AF: "cA = F" by simp
  from arg_cong[OF this, of "\<lambda> A. cis \<phi> *k A"]
  have sim: "cis \<phi> *k cA = inv_D ** cA ** D" unfolding F_def matrix.scale_scale cis_mult
    by simp
  have "similar_matrix (cis \<phi> *k cA) cA" unfolding similar_matrix_def similar_matrix_wit_def
     sim
    by (rule exI[of _ inv_D], rule exI[of _ D], auto simp: DD)
  thus ?thesis unfolding \<phi>_def .
qed

lemma assumes ev: "eigen_value cA \<alpha>" and \<alpha>: "cmod \<alpha> = sr"
  shows maximal_eigen_value_order_1: "order \<alpha> (charpoly cA) = 1"
    and maximal_eigen_value_rotation: "eigen_value cA (x * cis (arg \<alpha>)) = eigen_value cA x"
      "eigen_value cA (x / cis (arg \<alpha>)) = eigen_value cA x"
proof -
  let ?a = "cis (arg \<alpha>)"
  let ?p = "charpoly cA"
  from similar_matrix_rotation[OF ev \<alpha>]
  have "similar_matrix (?a *k cA) cA" .
  from similar_matrix_charpoly[OF this]
  have id: "charpoly (?a *k cA) = ?p" .
  have a: "?a \<noteq> 0" by simp
  from order_charpoly_smult[OF this, of _ cA, unfolded id]
  have order_neg: "order x ?p = order (x / ?a) ?p" for x .
  have order_pos: "order x ?p = order (x * ?a) ?p" for x
    using order_neg[symmetric, of "x * ?a"] by simp
  note order_neg[of \<alpha>]
  also have id: "\<alpha> / ?a = sr" unfolding \<alpha>[symmetric]
    by (metis a cis_mult_cmod_id nonzero_mult_div_cancel_left)
  also have sr: "order \<dots> ?p = 1" unfolding multiplicity_sr_1[symmetric] charpoly_of_real
    by (rule map_poly_inj_idom_divide_hom.order_hom, unfold_locales)
  finally show *: "order \<alpha> ?p = 1" .
  show "eigen_value cA (x * ?a) = eigen_value cA x" using order_pos
    unfolding eigen_value_root_charpoly order_root by auto
  show "eigen_value cA (x / ?a) = eigen_value cA x" using order_neg
    unfolding eigen_value_root_charpoly order_root by auto
qed

lemma maximal_eigen_values_group: assumes M: "M = {ev :: complex. eigen_value cA ev \<and> cmod ev = sr}"
  and a: "rcis sr \<alpha> \<in> M"
  and b: "rcis sr \<beta> \<in> M"
shows "rcis sr (\<alpha> + \<beta>) \<in> M" "rcis sr (\<alpha> - \<beta>) \<in> M" "rcis sr 0 \<in> M"
proof -
  {
    fix a
    assume *: "rcis sr a \<in> M"
    have id: "cis (arg (rcis sr a)) = cis a"
      by (smt * M mem_Collect_eq nonzero_mult_div_cancel_left of_real_eq_0_iff
         rcis_cmod_arg rcis_def sr_pos)
    from *[unfolded assms] have "eigen_value cA (rcis sr a)" "cmod (rcis sr a) = sr" by auto
    from maximal_eigen_value_rotation[OF this, unfolded id]
    have "eigen_value cA (x * cis a) = eigen_value cA x"
      "eigen_value cA (x / cis a) = eigen_value cA x" for x by auto
  } note * = this
  from *(1)[OF b, of "rcis sr \<alpha>"] a show "rcis sr (\<alpha> + \<beta>) \<in> M" unfolding M by auto
  from *(2)[OF a, of "rcis sr \<alpha>"] a show "rcis sr 0 \<in> M" unfolding M by auto
  from *(2)[OF b, of "rcis sr \<alpha>"] a show "rcis sr (\<alpha> - \<beta>) \<in> M" unfolding M by auto
qed

lemmas pf_main_connect = pf_main(1,3,5,7,8-10)[unfolded sr_spectral_radius]
  sr_pos[unfolded sr_spectral_radius]
end

end


theory Poincare_Lines_Axis_Intersections
  imports Poincare_Between
begin

(* ------------------------------------------------------------------ *)
section\<open>Intersection of h-lines with the x-axis in the Poincar\'e model\<close>
(* ------------------------------------------------------------------ *)

(* ---------------------------------------------------------------- *)
subsection\<open>Betweeness of x-axis intersection\<close>
(* ---------------------------------------------------------------- *)

text\<open>The intersection point of the h-line determined by points $u$ and $v$ and the x-axis is between
$u$ and $v$, then $u$ and $v$ are in the opposite half-planes (one must be in the upper, and the
other one in the lower half-plane).\<close>

lemma poincare_between_x_axis_intersection:
  assumes "u \<in> unit_disc" and "v \<in> unit_disc" and "z \<in> unit_disc" and "u \<noteq> v"
  assumes "u \<notin> circline_set x_axis" and "v \<notin> circline_set x_axis"
  assumes "z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
  shows "poincare_between u z v \<longleftrightarrow> arg (to_complex u) * arg (to_complex v) < 0"
proof-
  have "\<forall> u v. u \<in> unit_disc \<and> v \<in> unit_disc \<and> u \<noteq> v \<and>
       u \<notin> circline_set x_axis \<and> v \<notin> circline_set x_axis \<and>
       z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis \<longrightarrow>
       (poincare_between u z v \<longleftrightarrow> arg (to_complex u) * arg (to_complex v) < 0)" (is "?P z")
  proof (rule wlog_real_zero)
    show "?P 0\<^sub>h"
    proof ((rule allI)+, rule impI, (erule conjE)+)
      fix u v
      assume *: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v"
                "u \<notin> circline_set x_axis" "v \<notin> circline_set x_axis"
                "0\<^sub>h \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
      obtain u' v' where uv: "u = of_complex u'" "v = of_complex v'"
        using * inf_or_of_complex[of u] inf_or_of_complex[of v]
        by auto

      hence "u \<noteq> 0\<^sub>h" "v \<noteq> 0\<^sub>h" "u' \<noteq> 0" "v' \<noteq> 0"
        using *
        by auto

      hence "arg u' \<noteq> 0" "arg v' \<noteq> 0"
        using * arg_0_iff[of u'] arg_0_iff[of v']
        unfolding circline_set_x_axis uv
        by auto

      have "poincare_collinear {0\<^sub>h, u, v}"
        using *
        unfolding poincare_collinear_def
        by (rule_tac x="poincare_line u v" in exI, simp)
      have "(\<exists>k<0. u' = cor k * v') \<longleftrightarrow> (arg u' * arg v' < 0)" (is "?lhs \<longleftrightarrow> ?rhs")
      proof
        assume "?lhs"
        then obtain k where "k < 0" "u' = cor k * v'"
          by auto
        thus ?rhs
          using arg_mult_real_negative[of k v'] arg_uminus_opposite_sign[of v']
          using \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close> \<open>arg u' \<noteq> 0\<close> \<open>arg v' \<noteq> 0\<close>
          by (auto simp add: mult_neg_pos mult_pos_neg)
      next
        assume ?rhs
        obtain ru rv \<phi> where polar: "u' = cor ru * cis \<phi>" "v' = cor rv * cis \<phi>"
          using \<open>poincare_collinear {0\<^sub>h, u, v}\<close> poincare_collinear_zero_polar_form[of u' v'] uv * \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
          by auto
        have "ru * rv < 0"
          using polar \<open>?rhs\<close> \<open>u' \<noteq> 0\<close> \<open>v' \<noteq> 0\<close>
          using arg_mult_real_negative[of "ru" "cis \<phi>"] arg_mult_real_positive[of "ru" "cis \<phi>"]
          using arg_mult_real_negative[of "rv" "cis \<phi>"] arg_mult_real_positive[of "rv" "cis \<phi>"]
          apply (cases "ru > 0")
          apply (cases "rv > 0", simp, simp add: mult_pos_neg)
          apply (cases "rv > 0", simp add: mult_neg_pos, simp)
          done
        thus "?lhs"
          using polar
          by (rule_tac x="ru / rv" in exI, auto simp add: divide_less_0_iff mult_less_0_iff)
      qed
      thus "poincare_between u 0\<^sub>h v = (arg (to_complex u) * arg (to_complex v) < 0)"
        using poincare_between_u0v[of u v] * \<open>u \<noteq> 0\<^sub>h\<close> \<open>v \<noteq> 0\<^sub>h\<close> uv
        by simp
    qed
  next
    fix a z
    assume 1: "is_real a" "cmod a < 1" "z \<in> unit_disc"
    assume 2: "?P (moebius_pt (blaschke a) z)"
    show "?P z"
    proof ((rule allI)+, rule impI, (erule conjE)+)
      fix u v
      let ?M = "moebius_pt (blaschke a)"
      let ?Mu = "?M u"
      let ?Mv = "?M v"
      assume *: "u \<in> unit_disc" "v \<in> unit_disc" "u \<noteq> v" "u \<notin> circline_set x_axis" "v \<notin> circline_set x_axis"
      hence "u \<noteq> \<infinity>\<^sub>h" "v \<noteq> \<infinity>\<^sub>h"
        by auto

      have **: "\<And> x y :: real. x * y < 0 \<longleftrightarrow> sgn (x * y) < 0"
        by simp

      assume "z \<in> circline_set (poincare_line u v) \<inter> circline_set x_axis"
      thus "poincare_between u z v = (arg (to_complex u) * arg (to_complex v) < 0)"
        using * 1 2[rule_format, of ?Mu ?Mv] \<open>cmod a < 1\<close> \<open>is_real a\<close> blaschke_unit_disc_fix[of a]
        using inversion_noteq_unit_disc[of "of_complex a" u] \<open>u \<noteq> \<infinity>\<^sub>h\<close>
        using inversion_noteq_unit_disc[of "of_complex a" v] \<open>v \<noteq> \<infinity>\<^sub>h\<close>
        apply auto
        apply (subst (asm) **, subst **, subst (asm) sgn_mult, subst sgn_mult, simp)
        apply (subst (asm) **, subst (asm) **, subst (asm) sgn_mult, subst (asm) sgn_mult, simp)
        done
    qed
  next
    show "z \<in> unit_disc" by fact
  next
    show "is_real (to_complex z)"
      using assms inf_or_of_complex[of z]
      by (auto simp add: circline_set_x_axis)
  qed
  thus ?thesis
    using assms
    by simp
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Check if an h-line intersects the x-axis\<close>
(* ------------------------------------------------------------------ *)

lemma x_axis_intersection_equation:
  assumes
   "H = mk_circline A B C D" and
   "(A, B, C, D) \<in> hermitean_nonzero"
 shows "of_complex z \<in> circline_set x_axis \<inter> circline_set H \<longleftrightarrow>
        A*z\<^sup>2 + 2*Re B*z + D = 0 \<and> is_real z" (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  have "?lhs \<longleftrightarrow> A*z\<^sup>2 + (B + cnj B)*z + D = 0 \<and> z = cnj z"
    using assms
    using circline_equation_x_axis[of z]
    using circline_equation[of H A B C D z]
    using hermitean_elems
    by (auto simp add: power2_eq_square field_simps)
  thus ?thesis
    using eq_cnj_iff_real[of z]
    using hermitean_elems[of A B C D]
    by (simp add: complex_add_cnj complex_eq_if_Re_eq)
qed

text \<open>Check if an h-line intersects x-axis within the unit disc - this could be generalized to
checking if an arbitrary circline intersects the x-axis, but we do not need that.\<close>

definition intersects_x_axis_cmat :: "complex_mat \<Rightarrow> bool" where
  [simp]: "intersects_x_axis_cmat H = (let (A, B, C, D) = H in A = 0 \<or> (Re B)\<^sup>2 > (Re A)\<^sup>2)"

lift_definition intersects_x_axis_clmat :: "circline_mat \<Rightarrow> bool" is intersects_x_axis_cmat
  done

lift_definition intersects_x_axis :: "circline \<Rightarrow> bool" is intersects_x_axis_clmat
proof (transfer)
  fix H1 H2
  assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where k: "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto
  show "intersects_x_axis_cmat H1 = intersects_x_axis_cmat H2"
  proof-
    have "k \<noteq> 0 \<Longrightarrow> (Re A1)\<^sup>2 < (Re B1)\<^sup>2 \<longleftrightarrow> (k * Re A1)\<^sup>2 < (k * Re B1)\<^sup>2"
      by (smt mult_strict_left_mono power2_eq_square semiring_normalization_rules(13) zero_less_power2)
    thus ?thesis
      using * k
      by auto
  qed
qed

lemma intersects_x_axis_mk_circline:
  assumes "is_real A" and "A \<noteq> 0 \<or> B \<noteq> 0"
  shows "intersects_x_axis (mk_circline A B (cnj B) A) \<longleftrightarrow> A = 0 \<or> (Re B)\<^sup>2 > (Re A)\<^sup>2"
proof-
  let ?H = "(A, B, (cnj B),  A)"
  have "hermitean ?H"
    using `is_real A`
    unfolding hermitean_def mat_adj_def mat_cnj_def
    using eq_cnj_iff_real
    by auto
  moreover
  have "?H \<noteq> mat_zero"
    using assms
    by auto
  ultimately
  show ?thesis
    by (transfer, transfer, auto simp add: Let_def)
qed

lemma intersects_x_axis_iff:
  assumes "is_poincare_line H"
  shows "(\<exists> x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis) \<longleftrightarrow> intersects_x_axis H"
proof-
  obtain Ac B C Dc where  *: "H = mk_circline Ac B C Dc" "hermitean (Ac, B, C, Dc)" "(Ac, B, C, Dc) \<noteq> mat_zero"
    using ex_mk_circline[of H]
    by auto
  hence "(cmod B)\<^sup>2 > (cmod Ac)\<^sup>2" "Ac = Dc"
    using assms
    using is_poincare_line_mk_circline
    by auto

  hence "H = mk_circline (Re Ac) B (cnj B) (Re Ac)" "hermitean (cor (Re Ac),  B, (cnj B), cor (Re Ac))" "(cor (Re Ac),  B, (cnj B), cor (Re Ac)) \<noteq> mat_zero"
    using hermitean_elems[of Ac B C Dc] *
    by auto
  then obtain A where
    *: "H = mk_circline (cor A) B (cnj B) (cor A)" "(cor A,  B, (cnj B), cor A) \<in> hermitean_nonzero"
    by auto

  show ?thesis
  proof (cases "A = 0")
    case True
    thus ?thesis
      using *
      using x_axis_intersection_equation[OF *(1-2), of 0]
      using intersects_x_axis_mk_circline[of "cor A" B]
      by auto
  next
    case False
    show ?thesis
    proof
      assume "\<exists> x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis"
      then obtain x where **: "of_complex x \<in> unit_disc" "of_complex x \<in> circline_set H \<inter> circline_set x_axis"
        by (metis inf_or_of_complex inf_notin_unit_disc)
      hence "is_real x"
        unfolding circline_set_x_axis
        using of_complex_inj
        by auto
      hence eq: "A * (Re x)\<^sup>2 + 2 * Re B * Re x + A = 0"
        using **
        using x_axis_intersection_equation[OF *(1-2), of "Re x"]
        by simp
      hence "(2 * Re B)\<^sup>2 - 4 * A * A \<ge> 0"
        using discriminant_iff[of A _ "2 * Re B" A]
        using discrim_def[of A "2 * Re B" A] False
        by auto
      hence "(Re B)\<^sup>2 \<ge> (Re A)\<^sup>2"
        by (simp add: power2_eq_square)
      moreover
      have "(Re B)\<^sup>2 \<noteq> (Re A)\<^sup>2"
      proof (rule ccontr)
        assume "\<not> ?thesis"
        hence "Re B = Re A \<or> Re B = - Re A"
          using power2_eq_iff by blast
        hence "A * (Re x)\<^sup>2 +  A * 2* Re x + A = 0 \<or> A * (Re x)\<^sup>2 - A * 2 * Re x + A = 0"
          using eq
          by auto
        hence "A * ((Re x)\<^sup>2 +  2* Re x + 1) = 0 \<or> A * ((Re x)\<^sup>2 - 2 * Re x + 1) = 0"
          by (simp add: field_simps)
        hence "(Re x)\<^sup>2 + 2 * Re x + 1 = 0 \<or> (Re x)\<^sup>2 - 2 * Re x + 1 = 0"
          using \<open>A \<noteq> 0\<close>
          by simp
        hence "(Re x + 1)\<^sup>2 = 0 \<or> (Re x - 1)\<^sup>2 = 0"
          by (simp add: power2_sum power2_diff field_simps)
        hence "Re x = -1 \<or> Re x = 1"
          by auto
        thus False
          using \<open>is_real x\<close> \<open>of_complex x \<in> unit_disc\<close>
          by (auto simp add: cmod_eq_Re)
      qed
      ultimately
      show "intersects_x_axis H"
        using intersects_x_axis_mk_circline
        using *
        by auto
    next
      assume "intersects_x_axis H"
      hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
        using * False
        using intersects_x_axis_mk_circline
        by simp
      hence discr: "(2 * Re B)\<^sup>2 - 4 * A * A > 0"
        by (simp add: power2_eq_square)
      then obtain x1 x2 where
        eqs: "A * x1\<^sup>2 + 2 * Re B * x1 + A = 0" "A * x2\<^sup>2 + 2 * Re B * x2 + A = 0" "x1 \<noteq> x2"
        using discriminant_pos_ex[OF \<open>A \<noteq> 0\<close>, of "2 * Re B" A]
        using discrim_def[of A "2 * Re B" A]
        by auto
      hence "x1 * x2 = 1"
        using viette2[OF \<open>A \<noteq> 0\<close>, of "2 * Re B" A x1 x2] discr \<open>A \<noteq> 0\<close>
        by auto
      have "abs x1 \<noteq> 1" "abs x2 \<noteq> 1"
        using eqs discr \<open>x1 * x2 = 1\<close>
        by (auto simp add: abs_if power2_eq_square)
      hence "abs x1 < 1 \<or> abs x2 < 1"
        using \<open>x1 * x2 = 1\<close>
        by (smt mult_le_cancel_left1 mult_minus_right)
      thus "\<exists>x \<in> unit_disc. x \<in> circline_set H \<inter> circline_set x_axis"
        using x_axis_intersection_equation[OF *(1-2), of x1]
        using x_axis_intersection_equation[OF *(1-2), of x2]
        using eqs
        by auto
    qed
  qed
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Check if a Poincar\'e line intersects the y-axis\<close>
(* ------------------------------------------------------------------ *)

definition intersects_y_axis_cmat :: "complex_mat \<Rightarrow> bool" where
  [simp]: "intersects_y_axis_cmat H = (let (A, B, C, D) = H in A = 0 \<or> (Im B)\<^sup>2 > (Re A)\<^sup>2)"

lift_definition intersects_y_axis_clmat :: "circline_mat \<Rightarrow> bool" is intersects_y_axis_cmat
  done

lift_definition intersects_y_axis :: "circline \<Rightarrow> bool" is intersects_y_axis_clmat
proof (transfer)
  fix H1 H2
  assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where k: "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto
  show "intersects_y_axis_cmat H1 = intersects_y_axis_cmat H2"
  proof-
    have "k \<noteq> 0 \<Longrightarrow> (Re A1)\<^sup>2 < (Im B1)\<^sup>2 \<longleftrightarrow> (k * Re A1)\<^sup>2 < (k * Im B1)\<^sup>2"
      by (smt mult_strict_left_mono power2_eq_square semiring_normalization_rules(13) zero_less_power2)
    thus ?thesis
      using * k
      by auto
  qed
qed

lemma intersects_x_axis_intersects_y_axis [simp]:
  shows "intersects_x_axis (moebius_circline (moebius_rotation (pi/2)) H) \<longleftrightarrow> intersects_y_axis H"
  unfolding moebius_rotation_def moebius_similarity_def
  by simp (transfer, transfer, auto simp add: mat_adj_def mat_cnj_def)

lemma intersects_y_axis_iff:
  assumes "is_poincare_line H"
  shows "(\<exists> y \<in> unit_disc. y \<in> circline_set H \<inter> circline_set y_axis) \<longleftrightarrow> intersects_y_axis H" (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  let ?R = "moebius_rotation (pi / 2)"
  let ?H' = "moebius_circline ?R H"
  have 1: "is_poincare_line ?H'"
    using assms
    using unit_circle_fix_preserve_is_poincare_line[OF _ assms, of ?R]
    by simp

  show ?thesis
  proof
    assume "?lhs"
    then obtain y where "y \<in> unit_disc" "y \<in> circline_set H \<inter> circline_set y_axis"
      by auto
    hence "moebius_pt ?R y \<in> unit_disc \<and> moebius_pt ?R y \<in> circline_set ?H' \<inter> circline_set x_axis"
      using rotation_pi_2_y_axis
      by (metis Int_iff circline_set_moebius_circline_E moebius_circline_comp_inv_left moebius_pt_comp_inv_left unit_disc_fix_discI unit_disc_fix_rotation)
    thus ?rhs
      using intersects_x_axis_iff[OF 1]
      using intersects_x_axis_intersects_y_axis[of H]
      by auto
  next
    assume "intersects_y_axis H"
    hence "intersects_x_axis ?H'"
      using intersects_x_axis_intersects_y_axis[of H]
      by simp
    then obtain x where *: "x \<in> unit_disc" "x \<in> circline_set ?H' \<inter> circline_set x_axis"
      using intersects_x_axis_iff[OF 1]
      by auto
    let ?y = "moebius_pt (-?R) x"
    have "?y \<in> unit_disc \<and> ?y \<in> circline_set H \<inter> circline_set y_axis"
      using * rotation_pi_2_y_axis[symmetric]
      by (metis Int_iff circline_set_moebius_circline_E moebius_pt_comp_inv_left moebius_rotation_uminus uminus_moebius_def unit_disc_fix_discI unit_disc_fix_rotation)
    thus ?lhs
      by auto
  qed
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Intersection point of a Poincar\'e line with the x-axis in the unit disc\<close>
(* ------------------------------------------------------------------ *)

definition calc_x_axis_intersection_cvec :: "complex \<Rightarrow> complex \<Rightarrow> complex_vec" where
 [simp]:  "calc_x_axis_intersection_cvec A B =
    (let discr = (Re B)\<^sup>2 - (Re A)\<^sup>2 in
         (-Re(B) + sgn (Re B) * sqrt(discr), A))"

(* intersection with the x-axis for poincare lines that are euclidean circles *)
definition calc_x_axis_intersection_cmat_cvec :: "complex_mat \<Rightarrow> complex_vec" where [simp]:
  "calc_x_axis_intersection_cmat_cvec H =
    (let (A, B, C, D) = H in
       if A \<noteq> 0 then
          calc_x_axis_intersection_cvec A B
       else
          (0, 1)
    )"

lift_definition calc_x_axis_intersection_clmat_hcoords :: "circline_mat \<Rightarrow> complex_homo_coords" is calc_x_axis_intersection_cmat_cvec
  by (auto split: if_split_asm)

lift_definition calc_x_axis_intersection :: "circline \<Rightarrow> complex_homo" is calc_x_axis_intersection_clmat_hcoords
proof transfer
  fix H1 H2
  assume *: "hermitean H1 \<and> H1 \<noteq> mat_zero" "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where hh: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where k: "k \<noteq> 0" "H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto

  have "calc_x_axis_intersection_cvec A1 B1 \<approx>\<^sub>v calc_x_axis_intersection_cvec A2 B2"
    using hh k
    apply simp
    apply (rule_tac x="cor k" in exI)
    apply auto
    apply (simp add: sgn_mult power_mult_distrib)
    apply (subst right_diff_distrib[symmetric])
    apply (subst real_sqrt_mult)
    apply (subst cor_mult)
    by (simp add: real_sgn_eq right_diff_distrib)

  thus "calc_x_axis_intersection_cmat_cvec H1 \<approx>\<^sub>v
        calc_x_axis_intersection_cmat_cvec H2"
    using hh k
    by (auto simp del: calc_x_axis_intersection_cvec_def)
qed

lemma calc_x_axis_intersection_in_unit_disc:
  assumes "is_poincare_line H" "intersects_x_axis H"
  shows "calc_x_axis_intersection H \<in> unit_disc"
proof (cases "is_line H")
  case True
  thus ?thesis
    using assms
    unfolding unit_disc_def disc_def
    by simp (transfer, transfer, auto simp add: vec_cnj_def)
next
  case False
  thus ?thesis
    using assms
    unfolding unit_disc_def disc_def
  proof (simp, transfer, transfer)
    fix H
    assume hh: "hermitean H \<and> H \<noteq> mat_zero"
    then obtain A B D where *: "H = (A, B, cnj B, D)" "is_real A" "is_real D"
      using hermitean_elems
      by (cases H) blast
    assume "is_poincare_line_cmat H"
    hence *: "H = (A, B, cnj B, A)" "is_real A"
      using *
      by auto

    assume "\<not> circline_A0_cmat H"
    hence "A \<noteq> 0"
      using *
      by simp

    assume "intersects_x_axis_cmat H"
    hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
      using * \<open>A \<noteq> 0\<close>
      by (auto simp add: power2_eq_square complex.expand)

    hence "Re B \<noteq> 0"
      by auto

    have "Re A \<noteq> 0"
      using \<open>is_real A\<close> \<open>A \<noteq> 0\<close>
      by (auto simp add: complex.expand)

    have "sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) < sqrt((Re B)\<^sup>2)"
      using \<open>Re A \<noteq> 0\<close>
      by (subst real_sqrt_less_iff) auto
    also have "... =  sgn (Re B) * (Re B)"
      by (smt mult_minus_right nonzero_eq_divide_eq real_sgn_eq real_sqrt_abs)
    finally
    have 1: "sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) < sgn (Re B) * (Re B)"
      .

    have 2: "(Re B)\<^sup>2 - (Re A)\<^sup>2 < sgn (Re B) * (Re B) * sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
      using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
      using mult_strict_right_mono[OF 1, of "sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)"]
      by simp

    have 3: "(Re B)\<^sup>2 - 2*sgn (Re B)*Re B*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2) + (Re B)\<^sup>2 - (Re A)\<^sup>2 < (Re A)\<^sup>2"
      using mult_strict_left_mono[OF 2, of 2]
      by (simp add: field_simps)

    have "(sgn (Re B))\<^sup>2 = 1"
      using \<open>Re B \<noteq> 0\<close>
      by (simp add: sgn_if)

    hence "(-Re B + sgn (Re B) * sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 < (Re A)\<^sup>2"
      using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> 3
      by (simp add: power2_diff field_simps)

    thus "in_ocircline_cmat_cvec unit_circle_cmat (calc_x_axis_intersection_cmat_cvec H)"
      using * \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
      by (auto simp add: vec_cnj_def power2_eq_square split: if_split_asm)
  qed
qed

lemma calc_x_axis_intersection:
  assumes "is_poincare_line H" and "intersects_x_axis H"
  shows "calc_x_axis_intersection H \<in> circline_set H \<inter> circline_set x_axis"
proof (cases "is_line H")
  case True
  thus ?thesis
    using assms
    unfolding circline_set_def
    by simp (transfer, transfer, auto simp add: vec_cnj_def)
next
  case False
  thus ?thesis
    using assms
    unfolding circline_set_def
  proof (simp, transfer, transfer)
    fix H
    assume hh: "hermitean H \<and> H \<noteq> mat_zero"
    then obtain A B D where *: "H = (A, B, cnj B, D)" "is_real A" "is_real D"
      using hermitean_elems
      by (cases H) blast
    assume "is_poincare_line_cmat H"
    hence *: "H = (A, B, cnj B, A)" "is_real A"
      using *
      by auto
    assume "\<not> circline_A0_cmat H"
    hence "A \<noteq> 0"
      using *
      by auto

    assume "intersects_x_axis_cmat H"
    hence "(Re B)\<^sup>2 > (Re A)\<^sup>2"
      using * \<open>A \<noteq> 0\<close>
      by (auto simp add: power2_eq_square complex.expand)

    hence "Re B \<noteq> 0"
      by auto

    show "on_circline_cmat_cvec H (calc_x_axis_intersection_cmat_cvec H) \<and>
        on_circline_cmat_cvec x_axis_cmat (calc_x_axis_intersection_cmat_cvec H)" (is "?P1 \<and> ?P2")
    proof
      show "on_circline_cmat_cvec H (calc_x_axis_intersection_cmat_cvec H)"
      proof (cases "circline_A0_cmat H")
        case True
        thus ?thesis
          using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close>
          by (simp add: vec_cnj_def)
      next
        case False
        let ?x = "calc_x_axis_intersection_cvec A B"
        let ?nom = "fst ?x" and ?den = "snd ?x"
        have x: "?x = (?nom, ?den)"
          by simp

        hence "on_circline_cmat_cvec H (calc_x_axis_intersection_cvec A B)"
        proof (subst *, subst x, subst on_circline_cmat_cvec_circline_equation)
          have "(sgn(Re B))\<^sup>2 = 1"
            using \<open>Re B \<noteq> 0\<close> sgn_pos zero_less_power2 by fastforce
          have "(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 = (Re B)\<^sup>2 - (Re A)\<^sup>2"
            using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
            by simp

          have "(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
                (-(Re B))\<^sup>2 + (sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
            by (simp add: power2_diff)
          also have "... = (Re B)*(Re B) + (sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
            by (simp add: power2_eq_square)
          also have "... = (Re B)*(Re B) + (sgn(Re B))\<^sup>2*(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
            by (simp add: power_mult_distrib)
          also have "... = (Re B)*(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
            using \<open>(sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 = (Re B)\<^sup>2 - (Re A)\<^sup>2\<close> \<open>(sgn(Re B))\<^sup>2 = 1\<close>
            by simp
          finally have "(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
                        (Re B)*(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)"
            by simp

          have "is_real ?nom" "is_real ?den"
            using \<open>is_real A\<close>
            by simp+
          hence "cnj (?nom) = ?nom" "cnj (?den) = ?den"
            by (simp add:eq_cnj_iff_real)+
          hence "A*?nom*(cnj (?nom)) + B*?den*(cnj (?nom)) + (cnj B)*(cnj (?den))*?nom + A*?den*(cnj (?den))
                = A*?nom*?nom + B*?den*?nom + (cnj B)*?den*?nom + A*?den*?den"
            by auto
          also have "... = A*?nom*?nom + (B + (cnj B))*?den*?nom + A*?den*?den"
            by (simp add:field_simps)
          also have "... = A*?nom*?nom + 2*(Re B)*?den*?nom + A*?den*?den"
            by (simp add:complex_add_cnj)
          also have "... = A*?nom\<^sup>2 + 2*(Re B)*?den*?nom + A*?den*?den"
            by (simp add:power2_eq_square)
          also have "... = A*(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2
                           + 2*(Re B)*A*(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + A*A*A"
            unfolding calc_x_axis_intersection_cvec_def
            by auto
          also have "... = A*((Re B)*(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))
                     + 2*(Re B)*A*(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + A*A*A"
            using \<open>(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))\<^sup>2 =
                        (Re B)*(Re B) + (Re B)\<^sup>2 - (Re A)\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)\<close>
            by simp
          also have "... = A*((Re B)*(Re B) + (Re B)\<^sup>2 - A\<^sup>2 - 2*(Re B)*sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2))
                     + 2*(Re B)*A*(-(Re B) + sgn(Re B)*sqrt((Re B)\<^sup>2 - (Re A)\<^sup>2)) + A*A*A"
            using \<open>is_real A\<close>
            by simp
          also have "... = 0"
            apply (simp add:field_simps)
            by (simp add: power2_eq_square)
          finally have "A*?nom*(cnj (?nom)) + B*?den*(cnj (?nom)) + (cnj B)*(cnj (?den))*?nom + A*?den*(cnj (?den)) = 0"
            by simp
          thus "circline_equation A B (cnj B) A ?nom ?den"
            by simp
        qed
        thus ?thesis
          using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close>
          by (simp add: vec_cnj_def)
      qed
    next
      show  "on_circline_cmat_cvec x_axis_cmat (calc_x_axis_intersection_cmat_cvec H)"
        using * \<open>is_poincare_line_cmat H\<close> \<open>intersects_x_axis_cmat H\<close> \<open>is_real A\<close>
        using eq_cnj_iff_real[of A]
        by (simp add: vec_cnj_def)
    qed
  qed
qed

lemma unique_calc_x_axis_intersection:
  assumes "is_poincare_line H" and "H \<noteq> x_axis"
  assumes "x \<in> unit_disc" and "x \<in> circline_set H \<inter> circline_set x_axis"
  shows  "x = calc_x_axis_intersection H"
proof-
  have *: "intersects_x_axis H"
    using assms
    using intersects_x_axis_iff[OF assms(1)]
    by auto
  show "x = calc_x_axis_intersection H"
    using calc_x_axis_intersection[OF assms(1) *]
    using calc_x_axis_intersection_in_unit_disc[OF assms(1) *]
    using assms
    using unique_is_poincare_line[of x "calc_x_axis_intersection H" H x_axis]
    by auto
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Check if an h-line intersects the positive part of the x-axis\<close>
(* ------------------------------------------------------------------ *)

definition intersects_x_axis_positive_cmat :: "complex_mat \<Rightarrow> bool" where
  [simp]: "intersects_x_axis_positive_cmat H = (let (A, B, C, D) = H in Re A \<noteq> 0 \<and> Re B / Re A < -1)"

lift_definition intersects_x_axis_positive_clmat :: "circline_mat \<Rightarrow> bool" is intersects_x_axis_positive_cmat
  done

lift_definition intersects_x_axis_positive :: "circline \<Rightarrow> bool" is intersects_x_axis_positive_clmat
proof (transfer)
  fix H1 H2
  assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto
  thus "intersects_x_axis_positive_cmat H1 = intersects_x_axis_positive_cmat H2"
    using *
    by simp
qed

lemma intersects_x_axis_positive_mk_circline:
  assumes "is_real A" and "A \<noteq> 0 \<or> B \<noteq> 0"
  shows "intersects_x_axis_positive (mk_circline A B (cnj B) A) \<longleftrightarrow> Re B / Re A < -1"
proof-
  let ?H = "(A, B, (cnj B),  A)"
  have "hermitean ?H"
    using `is_real A`
    unfolding hermitean_def mat_adj_def mat_cnj_def
    using eq_cnj_iff_real
    by auto
  moreover
  have "?H \<noteq> mat_zero"
    using assms
    by auto
  ultimately
  show ?thesis
    by (transfer, transfer, auto simp add: Let_def)
qed

lemma intersects_x_axis_positive_intersects_x_axis [simp]:
  assumes "intersects_x_axis_positive H"
  shows "intersects_x_axis H"
proof-
  have "\<And> a aa. \<lbrakk> Re a \<noteq> 0; Re aa / Re a < - 1; \<not> (Re a)\<^sup>2 < (Re aa)\<^sup>2 \<rbrakk> \<Longrightarrow> aa = 0 \<and> a = 0"
    by (smt less_divide_eq_1_pos one_less_power pos2 power2_minus power_divide zero_less_power2)
  thus ?thesis
    using assms
    apply transfer
    apply transfer
    apply (auto simp add: hermitean_def mat_adj_def mat_cnj_def)
    done
qed

lemma add_less_abs_positive_iff:
  fixes a b :: real
  assumes "abs b < abs a"
  shows "a + b > 0 \<longleftrightarrow> a > 0"
  using assms
  by auto

lemma calc_x_axis_intersection_positive_abs':
  fixes A B :: real
  assumes "B\<^sup>2 > A\<^sup>2" and "A \<noteq> 0"
  shows "abs (sgn(B) * sqrt(B\<^sup>2 - A\<^sup>2) / A) < abs(-B/A)"
proof-
  from assms have "B \<noteq> 0"
    by auto

  have "B\<^sup>2 - A\<^sup>2 < B\<^sup>2"
    using \<open>A \<noteq> 0\<close>
    by auto
  hence "sqrt (B\<^sup>2 - A\<^sup>2) < abs B"
    using real_sqrt_less_iff[of "B\<^sup>2 - A\<^sup>2" "B\<^sup>2"]
    by simp
  thus ?thesis
    using assms \<open>B \<noteq> 0\<close>
    by (simp add: abs_mult divide_strict_right_mono)
qed

lemma calc_intersect_x_axis_positive_lemma:
  assumes "B\<^sup>2 > A\<^sup>2" and "A \<noteq> 0"
  shows "(-B + sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A > 0 \<longleftrightarrow> -B/A > 1"
proof-
  have "(-B + sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A = -B / A + (sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A"
    using assms
    by (simp add: field_simps)
  moreover
  have "-B / A + (sgn B * sqrt(B\<^sup>2 - A\<^sup>2)) / A > 0 \<longleftrightarrow> - B / A > 0"
    using add_less_abs_positive_iff[OF calc_x_axis_intersection_positive_abs'[OF assms]]
    by simp
  moreover
  hence "(B/A)\<^sup>2 > 1"
    using assms
    by (simp add: power_divide)
  hence "B/A > 1 \<or> B/A < -1"
    by (smt one_power2 pos2 power2_minus power_0 power_strict_decreasing zero_power2)
  hence "-B / A > 0 \<longleftrightarrow> -B / A > 1"
    by auto
  ultimately
  show ?thesis
    using assms
    by auto
qed

lemma intersects_x_axis_positive_iff':
  assumes "is_poincare_line H"
  shows "intersects_x_axis_positive H \<longleftrightarrow>
         calc_x_axis_intersection H \<in> unit_disc \<and> calc_x_axis_intersection H \<in> circline_set H \<inter> positive_x_axis" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  let ?x = "calc_x_axis_intersection H"
  assume ?lhs
  hence "?x \<in> circline_set x_axis" "?x \<in> circline_set H" "?x \<in> unit_disc"
    using calc_x_axis_intersection_in_unit_disc[OF assms] calc_x_axis_intersection[OF assms]
    by auto
  moreover
  have "Re (to_complex ?x) > 0"
    using \<open>?lhs\<close> assms
  proof (transfer, transfer)
    fix H
    assume hh: "hermitean H \<and> H \<noteq> mat_zero"
    obtain A B C D where *: "H = (A, B, C, D)"
      by (cases H, auto)
    assume "intersects_x_axis_positive_cmat H"
    hence **: "Re B / Re A < - 1" "Re A \<noteq> 0"
      using *
      by auto
    have "(Re B)\<^sup>2 > (Re A)\<^sup>2"
      using **
      by (smt divide_less_eq_1_neg divide_minus_left less_divide_eq_1_pos real_sqrt_abs real_sqrt_less_iff right_inverse_eq)
    have "is_real A" "A \<noteq> 0"
      using hh hermitean_elems * \<open>Re A \<noteq> 0\<close> complex.expand[of A 0]
      by auto
    have "(cmod B)\<^sup>2 > (cmod A)\<^sup>2"
      using \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> \<open>is_real A\<close>
      by (smt cmod_power2 power2_less_0 zero_power2)
    have ***: "0 < (- Re B + sgn (Re B) * sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) / Re A"
      using calc_intersect_x_axis_positive_lemma[of "Re A" "Re B"] ** \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close>
      by auto

    assume "is_poincare_line_cmat H"
    hence "A = D"
      using * hh
      by simp

    have "Re ((cor (sgn (Re B)) * cor (sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) - cor (Re B)) / A) = (sgn (Re B) * sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2) - Re B) / Re D"
      using \<open>is_real A\<close> \<open>A = D\<close>
      by (metis (no_types, lifting) Re_complex_of_real complex_of_real_Re of_real_diff of_real_divide of_real_mult)
    thus "0 < Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H))"
      using * hh ** *** \<open>(cmod B)\<^sup>2 > (cmod A)\<^sup>2\<close> \<open>(Re B)\<^sup>2 > (Re A)\<^sup>2\<close> \<open>A \<noteq> 0\<close> \<open>A = D\<close>
      by simp
  qed
  ultimately
  show ?rhs
    unfolding positive_x_axis_def
    by auto
next
  let ?x = "calc_x_axis_intersection H"
  assume ?rhs
  hence "Re (to_complex ?x) > 0"  "?x \<noteq> \<infinity>\<^sub>h" "?x \<in> circline_set x_axis" "?x \<in> unit_disc" "?x \<in> circline_set H"
    unfolding positive_x_axis_def
    by auto
  hence "intersects_x_axis H"
    using intersects_x_axis_iff[OF assms]
    by auto
  thus ?lhs
    using \<open>Re (to_complex ?x) > 0\<close> assms
  proof (transfer, transfer)
    fix H
    assume hh: "hermitean H \<and> H \<noteq> mat_zero"
    obtain A B C D where *: "H = (A, B, C, D)"
      by (cases H, auto)
    assume "0 < Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H))" "intersects_x_axis_cmat H" "is_poincare_line_cmat H"
    hence **: "A \<noteq> 0" "0 < Re ((cor (sgn (Re B)) * cor (sqrt ((Re B)\<^sup>2 - (Re A)\<^sup>2)) - cor (Re B)) / A)"  "A = D" "is_real A" "(Re B)\<^sup>2 > (Re A)\<^sup>2"
      using * hh hermitean_elems
      by (auto split: if_split_asm)

    have "Re A \<noteq> 0"
      using complex.expand[of A 0] \<open>A \<noteq> 0\<close> \<open>is_real A\<close>
      by auto

    have "Re ((cor (sgn (Re B)) * cor (sqrt ((Re B)\<^sup>2 - (Re D)\<^sup>2)) - cor (Re B)) / D) = (sgn (Re B) * sqrt ((Re B)\<^sup>2 - (Re D)\<^sup>2) - Re B) / Re D"
      using \<open>is_real A\<close> \<open>A = D\<close>
      by (metis (no_types, lifting) Re_complex_of_real complex_of_real_Re of_real_diff of_real_divide of_real_mult)

    thus "intersects_x_axis_positive_cmat H"
      using * ** \<open>Re A \<noteq> 0\<close>
      using calc_intersect_x_axis_positive_lemma[of "Re A" "Re B"]
      by simp
  qed
qed

lemma intersects_x_axis_positive_iff:
  assumes "is_poincare_line H" and "H \<noteq> x_axis"
  shows "intersects_x_axis_positive H \<longleftrightarrow>
         (\<exists> x. x \<in> unit_disc \<and> x \<in> circline_set H \<inter> positive_x_axis)" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  thus ?rhs
    using intersects_x_axis_positive_iff'[OF assms(1)]
    by auto
next
  assume ?rhs
  then obtain x where "x \<in> unit_disc" "x \<in> circline_set H \<inter> positive_x_axis"
    by auto
  thus ?lhs
    using unique_calc_x_axis_intersection[OF assms, of x]
    using intersects_x_axis_positive_iff'[OF assms(1)]
    unfolding positive_x_axis_def
    by auto
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Check if an h-line intersects the positive part of the y-axis\<close>
(* ------------------------------------------------------------------ *)

definition intersects_y_axis_positive_cmat :: "complex_mat \<Rightarrow> bool" where
  [simp]: "intersects_y_axis_positive_cmat H = (let (A, B, C, D) = H in Re A \<noteq> 0 \<and> Im B / Re A < -1)"

lift_definition intersects_y_axis_positive_clmat :: "circline_mat \<Rightarrow> bool" is intersects_y_axis_positive_cmat
  done

lift_definition intersects_y_axis_positive :: "circline \<Rightarrow> bool" is intersects_y_axis_positive_clmat
proof (transfer)
  fix H1 H2
  assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero" and "hermitean H2 \<and> H2 \<noteq> mat_zero"
  obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
    by (cases H1, cases H2, auto)
  assume "circline_eq_cmat H1 H2"
  then obtain k where "k \<noteq> 0 \<and> H2 = cor k *\<^sub>s\<^sub>m H1"
    by auto
  thus "intersects_y_axis_positive_cmat H1 = intersects_y_axis_positive_cmat H2"
    using *
    by simp
qed

lemma intersects_x_axis_positive_intersects_y_axis_positive [simp]:
  shows "intersects_x_axis_positive (moebius_circline (moebius_rotation (-pi/2)) H) \<longleftrightarrow> intersects_y_axis_positive H"
  using hermitean_elems
  unfolding moebius_rotation_def moebius_similarity_def
  by simp (transfer, transfer, auto simp add: mat_adj_def mat_cnj_def)

lemma intersects_y_axis_positive_iff:
  assumes "is_poincare_line H" "H \<noteq> y_axis"
  shows "(\<exists> y \<in> unit_disc. y \<in> circline_set H \<inter> positive_y_axis) \<longleftrightarrow> intersects_y_axis_positive H" (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  let ?R = "moebius_rotation (-pi / 2)"
  let ?H' = "moebius_circline ?R H"
  have 1: "is_poincare_line ?H'"
    using assms
    using unit_circle_fix_preserve_is_poincare_line[OF _ assms(1), of ?R]
    by simp

  have 2: "moebius_circline ?R H \<noteq> x_axis"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "H = moebius_circline (moebius_rotation (pi/2)) x_axis"
      using moebius_circline_comp_inv_left[of ?R H]
      by auto
    thus False
      using \<open>H \<noteq> y_axis\<close>
      by auto
  qed

  show ?thesis
  proof
    assume "?lhs"
    then obtain y where "y \<in> unit_disc" "y \<in> circline_set H \<inter> positive_y_axis"
      by auto
    hence "moebius_pt ?R y \<in> unit_disc" "moebius_pt ?R y \<in> circline_set ?H' \<inter> positive_x_axis"
      using rotation_minus_pi_2_positive_y_axis
      by auto
    thus ?rhs
      using intersects_x_axis_positive_iff[OF 1 2]
      using intersects_x_axis_positive_intersects_y_axis_positive[of H]
      by auto
  next
    assume "intersects_y_axis_positive H"
    hence "intersects_x_axis_positive ?H'"
      using intersects_x_axis_positive_intersects_y_axis_positive[of H]
      by simp
    then obtain x where *: "x \<in> unit_disc" "x \<in> circline_set ?H' \<inter> positive_x_axis"
      using intersects_x_axis_positive_iff[OF 1 2]
      by auto
    let ?y = "moebius_pt (-?R) x"
    have "?y \<in> unit_disc \<and> ?y \<in> circline_set H \<inter> positive_y_axis"
      using * rotation_minus_pi_2_positive_y_axis[symmetric]
      by (metis Int_iff circline_set_moebius_circline_E image_eqI moebius_pt_comp_inv_image_left moebius_rotation_uminus uminus_moebius_def unit_disc_fix_discI unit_disc_fix_rotation)
    thus ?lhs
      by auto
  qed
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Position of the intersection point in the unit disc\<close>
(* ------------------------------------------------------------------ *)

text\<open>Check if the intersection point of one h-line with the x-axis is located more outward the edge
of the disc than the intersection point of another h-line.\<close>

definition outward_cmat :: "complex_mat \<Rightarrow> complex_mat \<Rightarrow> bool" where
 [simp]: "outward_cmat H1 H2 = (let (A1, B1, C1, D1) = H1; (A2, B2, C2, D2) = H2
                                 in -Re B1/Re A1 \<le> -Re B2/Re A2)"
lift_definition outward_clmat :: "circline_mat \<Rightarrow> circline_mat \<Rightarrow> bool" is outward_cmat
  done
lift_definition outward :: "circline \<Rightarrow> circline \<Rightarrow> bool" is outward_clmat
  apply transfer
  apply simp
  apply (case_tac circline_mat1, case_tac circline_mat2, case_tac circline_mat3, case_tac circline_mat4)
  apply simp
  apply (erule_tac exE)+
  apply (erule_tac conjE)+
  apply simp
  done

lemma outward_mk_circline:
  assumes "is_real A1" and "is_real A2" and "A1 \<noteq> 0 \<or> B1 \<noteq> 0" and "A2 \<noteq> 0 \<or> B2 \<noteq> 0"
  shows "outward (mk_circline A1 B1 (cnj B1) A1) (mk_circline A2 B2 (cnj B2) A2) \<longleftrightarrow> - Re B1 / Re A1 \<le> - Re B2 / Re A2"
proof-
  let ?H1 = "(A1, B1, (cnj B1),  A1)"
  let ?H2 = "(A2, B2, (cnj B2),  A2)"
  have "hermitean ?H1" "hermitean ?H2"
    using `is_real A1` `is_real A2`
    unfolding hermitean_def mat_adj_def mat_cnj_def
    using eq_cnj_iff_real
    by auto
  moreover
  have "?H1 \<noteq> mat_zero" "?H2 \<noteq> mat_zero"
    using assms
    by auto
  ultimately
  show ?thesis
    by (transfer, transfer, auto simp add: Let_def)
qed

lemma calc_x_axis_intersection_fun_mono:
  fixes x1 x2 :: real
  assumes "x1 > 1" and "x2 > x1"
  shows "x1 - sqrt(x1\<^sup>2 - 1) > x2 - sqrt(x2\<^sup>2 - 1)"
  using assms
proof-
  have *: "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1) > 0"
    using assms
    by (smt one_less_power pos2 real_sqrt_gt_zero)

  have "sqrt(x1\<^sup>2 - 1) < x1"
    using real_sqrt_less_iff[of "x1\<^sup>2 - 1" "x1\<^sup>2"] \<open>x1 > 1\<close>
    by auto
  moreover
  have "sqrt(x2\<^sup>2 - 1) < x2"
    using real_sqrt_less_iff[of "x2\<^sup>2 - 1" "x2\<^sup>2"] \<open>x1 > 1\<close> \<open>x2 > x1\<close>
    by auto
  ultimately
  have "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1) < x1 + x2"
    by simp
  hence "(x1 + x2) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) > 1"
    using *
    using less_divide_eq_1_pos[of "sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)" "x1 + x2"]
    by simp
  hence "(x2\<^sup>2 - x1\<^sup>2) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) > x2 - x1"
    using \<open>x2 > x1\<close>
    using mult_less_cancel_left_pos[of "x2 - x1" 1 "(x2 + x1) / (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1))"]
    by (simp add: power2_eq_square field_simps)
  moreover
  have "(x2\<^sup>2 - x1\<^sup>2) = (sqrt(x1\<^sup>2 - 1) + sqrt(x2\<^sup>2 - 1)) * ((sqrt(x2\<^sup>2 - 1) - sqrt(x1\<^sup>2 - 1)))"
    using \<open>x1 > 1\<close> \<open>x2 > x1\<close>
    by (simp add: field_simps)
  ultimately
  have "sqrt(x2\<^sup>2 - 1) - sqrt(x1\<^sup>2 - 1) > x2 - x1"
    using *
    by simp
  thus ?thesis
    by simp
qed

lemma calc_x_axis_intersection_mono:
  fixes a1 b1 a2 b2 :: real
  assumes "-b1/a1 > 1" and "a1 \<noteq> 0" and "-b2/a2 \<ge> -b1/a1" and "a2 \<noteq> 0"
  shows "(-b1 + sgn b1 * sqrt(b1\<^sup>2 - a1\<^sup>2)) / a1 \<ge> (-b2 + sgn b2 * sqrt(b2\<^sup>2 - a2\<^sup>2)) / a2" (is "?lhs \<ge> ?rhs")
proof-
  have "?lhs = -b1/a1 - sqrt((-b1/a1)\<^sup>2 - 1)"
  proof (cases "b1 > 0")
    case True
    hence "a1 < 0"
      using assms
      by (smt divide_neg_pos)
    thus ?thesis
      using \<open>b1 > 0\<close> \<open>a1 < 0\<close>
      by (simp add: real_sqrt_divide field_simps)
  next
    case False
    hence "b1 < 0"
      using assms
      by (cases "b1 = 0") auto
    hence "a1 > 0"
      using assms
      by (smt divide_pos_neg)
    thus ?thesis
      using \<open>b1 < 0\<close> \<open>a1 > 0\<close>
      by (simp add: real_sqrt_divide field_simps)
  qed

  moreover

  have "?rhs = -b2/a2 - sqrt((-b2/a2)\<^sup>2 - 1)"
  proof (cases "b2 > 0")
    case True
    hence "a2 < 0"
      using assms
      by (smt divide_neg_pos)
    thus ?thesis
      using \<open>b2 > 0\<close> \<open>a2 < 0\<close>
      by (simp add: real_sqrt_divide field_simps)
  next
    case False
    hence "b2 < 0"
      using assms
      by (cases "b2 = 0") auto
    hence "a2 > 0"
      using assms
      by (smt divide_pos_neg)
    thus ?thesis
      using \<open>b2 < 0\<close> \<open>a2 > 0\<close>
      by (simp add: real_sqrt_divide field_simps)
  qed

  ultimately

  show ?thesis
    using calc_x_axis_intersection_fun_mono[of "-b1/a1" "-b2/a2"]
    using assms
    by (cases "-b1/a1=-b2/a2", auto)
qed

lemma outward:
  assumes "is_poincare_line H1" and "is_poincare_line H2"
  assumes "intersects_x_axis_positive H1" and "intersects_x_axis_positive H2"
  assumes "outward H1 H2"
  shows "Re (to_complex (calc_x_axis_intersection H1)) \<ge> Re (to_complex (calc_x_axis_intersection H2))"
proof-
  have "intersects_x_axis H1" "intersects_x_axis H2"
    using assms
    by auto
  thus ?thesis
    using assms
  proof (transfer, transfer)
    fix H1 H2
    assume hh: "hermitean H1 \<and> H1 \<noteq> mat_zero"  "hermitean H2 \<and> H2 \<noteq> mat_zero"
    obtain A1 B1 C1 D1 A2 B2 C2 D2 where *: "H1 = (A1, B1, C1, D1)" "H2 = (A2, B2, C2, D2)"
      by (cases H1, cases H2, auto)
    have "is_real A1" "is_real A2"
      using hermitean_elems * hh
      by auto
    assume 1: "intersects_x_axis_positive_cmat H1" "intersects_x_axis_positive_cmat H2"
    assume 2: "intersects_x_axis_cmat H1" "intersects_x_axis_cmat H2"
    assume 3: "is_poincare_line_cmat H1" "is_poincare_line_cmat H2"
    assume 4: "outward_cmat H1 H2"
    have "A1 \<noteq> 0" "A2 \<noteq> 0"
      using * \<open>is_real A1\<close> \<open>is_real A2\<close> 1 complex.expand[of A1 0] complex.expand[of A2 0]
      by auto
    hence "(sgn (Re B2) * sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2) - Re B2) / Re A2
         \<le> (sgn (Re B1) * sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2) - Re B1) / Re A1"
      using calc_x_axis_intersection_mono[of "Re B1" "Re A1" "Re B2" "Re A2"]
      using 1 4 *
      by simp
    moreover
    have "(sgn (Re B2) * sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2) - Re B2) / Re A2 =
          Re ((cor (sgn (Re B2)) * cor (sqrt ((Re B2)\<^sup>2 - (Re A2)\<^sup>2)) - cor (Re B2)) / A2)"
      using \<open>is_real A2\<close> \<open>A2 \<noteq> 0\<close>
      by (simp add: Re_divide_real)
    moreover
    have "(sgn (Re B1) * sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2) - Re B1) / Re A1 =
           Re ((cor (sgn (Re B1)) * cor (sqrt ((Re B1)\<^sup>2 - (Re A1)\<^sup>2)) - cor (Re B1)) / A1)"
      using \<open>is_real A1\<close> \<open>A1 \<noteq> 0\<close>
      by (simp add: Re_divide_real)
    ultimately
    show "Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H2))
          \<le> Re (to_complex_cvec (calc_x_axis_intersection_cmat_cvec H1))"
      using 2 3 \<open>A1 \<noteq> 0\<close> \<open>A2 \<noteq> 0\<close> * \<open>is_real A1\<close> \<open>is_real A2\<close>
      by (simp del: is_poincare_line_cmat_def intersects_x_axis_cmat_def)
  qed
qed

(* ------------------------------------------------------------------ *)
subsection\<open>Ideal points and x-axis intersection\<close>
(* ------------------------------------------------------------------ *)

lemma ideal_points_intersects_x_axis:
  assumes "is_poincare_line H" and "ideal_points H = {i1, i2}" and "H \<noteq> x_axis"
  shows  "intersects_x_axis H \<longleftrightarrow> Im (to_complex i1) * Im (to_complex i2) < 0"
  using assms
proof-
  have "i1 \<noteq> i2"
    using assms(1) assms(2) ex_poincare_line_points ideal_points_different(1)
    by blast

  have "calc_ideal_points H = {i1, i2}"
    using assms
    using ideal_points_unique
    by auto

  have "\<forall> i1 \<in> calc_ideal_points H.
        \<forall> i2 \<in> calc_ideal_points H.
             is_poincare_line H \<and> H \<noteq> x_axis \<and> i1 \<noteq> i2 \<longrightarrow> (Im (to_complex i1) * Im (to_complex i2) < 0 \<longleftrightarrow> intersects_x_axis H)"
  proof (transfer, transfer, (rule ballI)+, rule impI, (erule conjE)+, case_tac H, case_tac i1, case_tac i2)
    fix i11 i12 i21 i22 A B C D H i1 i2
    assume H: "H = (A, B, C, D)" "hermitean H" "H \<noteq> mat_zero"
    assume line: "is_poincare_line_cmat H"
    assume i1: "i1 = (i11, i12)" "i1 \<in> calc_ideal_points_cmat_cvec H"
    assume i2: "i2 = (i21, i22)" "i2 \<in> calc_ideal_points_cmat_cvec H"
    assume different: "\<not> i1 \<approx>\<^sub>v i2"
    assume not_x_axis:  "\<not> circline_eq_cmat H x_axis_cmat"

    have "is_real A" "is_real D" "C = cnj B"
      using H hermitean_elems
      by auto
    have "(cmod A)\<^sup>2 < (cmod B)\<^sup>2" "A = D"
      using line H
      by auto

    let ?discr =  "sqrt ((cmod B)\<^sup>2 - (Re D)\<^sup>2)"
    let ?den = "(cmod B)\<^sup>2"
    let ?i1 = "B * (- D - \<i> * ?discr)"
    let ?i2 = "B * (- D + \<i> * ?discr)"

    have "i11 = ?i1 \<or> i11 = ?i2" "i12 = ?den"
         "i21 = ?i1 \<or> i21 = ?i2" "i22 = ?den"
      using i1 i2 H line
      by (auto split: if_split_asm)
    hence i: "i11 = ?i1 \<and> i21 = ?i2 \<or> i11 = ?i2 \<and> i21 = ?i1"
      using `\<not> i1 \<approx>\<^sub>v i2` i1 i2
      by auto

    have "Im (i11 / i12) * Im (i21 / i22) = Im (?i1 / ?den) * Im (?i2 / ?den)"
      using i `i12 = ?den` `i22 = ?den`
      by auto
    also have "... = Im (?i1) * Im (?i2) / ?den\<^sup>2"
      by simp
    also have "... = (Im B * (Im B * (Re D * Re D)) - Re B * (Re B * ((cmod B)\<^sup>2 - (Re D)\<^sup>2))) / cmod B ^ 4"
      using `(cmod B)\<^sup>2 > (cmod A)\<^sup>2` `A = D`
      using `is_real D` cmod_eq_Re[of A]
      by (auto simp add: field_simps)
    also have "... = ((Im B)\<^sup>2 * (Re D)\<^sup>2 - (Re B)\<^sup>2 * ((Re B)\<^sup>2 + (Im B)\<^sup>2 - (Re D)\<^sup>2)) / cmod B ^ 4"
    proof-
      have "cmod B * cmod B = Re B * Re B + Im B * Im B"
        by (metis cmod_power2 power2_eq_square)
      thus ?thesis
        by (simp add: power2_eq_square)
    qed
    also have "... = (((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2)) / cmod B ^ 4"
      by (simp add: power2_eq_square field_simps)
    finally have Im_product: "Im (i11 / i12) * Im (i21 / i22) = ((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) / cmod B ^ 4"
      .

    show "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0 \<longleftrightarrow> intersects_x_axis_cmat H"
    proof safe
      assume opposite: "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0"
      show "intersects_x_axis_cmat H"
      proof-
        have "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) / cmod B ^ 4 < 0"
          using Im_product opposite i1 i2
          by simp
        hence "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) < 0"
          by (simp add: divide_less_0_iff)
        hence "(Re D)\<^sup>2 < (Re B)\<^sup>2"
          by (simp add: mult_less_0_iff not_sum_power2_lt_zero)
        thus ?thesis
          using H `A = D`  `is_real D`
          by auto
      qed
    next
      have *: "(\<forall>k. k * Im B = 1 \<longrightarrow> k = 0) \<longrightarrow> Im B = 0"
        apply (safe, erule_tac x="1 / Im B" in allE)
        using divide_cancel_left by fastforce
      assume "intersects_x_axis_cmat H"
      hence "Re D = 0 \<or> (Re D)\<^sup>2 < (Re B)\<^sup>2"
        using H `A = D`
        by auto
      hence "(Re D)\<^sup>2 < (Re B)\<^sup>2"
        using `is_real D` line  H `C = cnj B`
        using not_x_axis *
        by (auto simp add: complex_eq_iff)
      hence "((Re D)\<^sup>2 - (Re B)\<^sup>2) * ((Re B)\<^sup>2 + (Im B)\<^sup>2) < 0"
        by (metis add_cancel_left_left diff_less_eq mult_eq_0_iff mult_less_0_iff power2_eq_square power2_less_0 sum_squares_gt_zero_iff)
      thus "Im (to_complex_cvec i1) * Im (to_complex_cvec i2) < 0"
        using Im_product i1 i2
        using divide_eq_0_iff divide_less_0_iff prod.simps(2) to_complex_cvec_def zero_complex.simps(1) zero_less_norm_iff
        by fastforce
    qed
  qed
  thus ?thesis
    using assms `calc_ideal_points H = {i1, i2}` `i1 \<noteq> i2`
    by auto
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_list_perm_symm
imports "../../Test_Base"
begin

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

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "((isPermutation xs ys) ==> (isPermutation ys xs))"
  oops

end