theory Isolated
  imports "HOL-Analysis.Elementary_Metric_Spaces"

begin

subsection \<open>Isolate and discrete\<close>

definition (in topological_space) isolated_in:: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infixr "isolated'_in" 60)
  where "x isolated_in S \<longleftrightarrow> (x\<in>S \<and> (\<exists>T. open T \<and> T \<inter> S = {x}))"

definition (in topological_space) discrete:: "'a set \<Rightarrow> bool"
  where "discrete S \<longleftrightarrow> (\<forall>x\<in>S. x isolated_in S)"

definition (in metric_space) uniform_discrete :: "'a set \<Rightarrow> bool" where
  "uniform_discrete S \<longleftrightarrow> (\<exists>e>0. \<forall>x\<in>S. \<forall>y\<in>S. dist x y < e \<longrightarrow> x = y)"

lemma discreteI: "(\<And>x. x \<in> X \<Longrightarrow> x isolated_in X ) \<Longrightarrow> discrete X"
  unfolding discrete_def by auto

lemma discreteD: "discrete X \<Longrightarrow> x \<in> X \<Longrightarrow> x isolated_in X "
  unfolding discrete_def by auto

lemma uniformI1:
  assumes "e>0" "\<And>x y. \<lbrakk>x\<in>S;y\<in>S;dist x y<e\<rbrakk> \<Longrightarrow> x =y "
  shows "uniform_discrete S"
unfolding uniform_discrete_def using assms by auto

lemma uniformI2:
  assumes "e>0" "\<And>x y. \<lbrakk>x\<in>S;y\<in>S;x\<noteq>y\<rbrakk> \<Longrightarrow> dist x y\<ge>e "
  shows "uniform_discrete S"
unfolding uniform_discrete_def using assms not_less by blast

lemma isolated_in_islimpt_iff:"(x isolated_in S) \<longleftrightarrow> (\<not> (x islimpt S) \<and> x\<in>S)"
  unfolding isolated_in_def islimpt_def by auto

lemma isolated_in_dist_Ex_iff:
  fixes x::"'a::metric_space"
  shows "x isolated_in S \<longleftrightarrow> (x\<in>S \<and> (\<exists>e>0. \<forall>y\<in>S. dist x y < e \<longrightarrow> y=x))"
unfolding isolated_in_islimpt_iff islimpt_approachable by (metis dist_commute)

lemma discrete_empty[simp]: "discrete {}"
  unfolding discrete_def by auto

lemma uniform_discrete_empty[simp]: "uniform_discrete {}"
  unfolding uniform_discrete_def by (simp add: gt_ex)

lemma isolated_in_insert:
  fixes x :: "'a::t1_space"
  shows "x isolated_in (insert a S) \<longleftrightarrow> x isolated_in S \<or> (x=a \<and> \<not> (x islimpt S))"
by (meson insert_iff islimpt_insert isolated_in_islimpt_iff)

lemma isolated_inI:
  assumes "x\<in>S" "open T" "T \<inter> S = {x}"
  shows   "x isolated_in S"
  using assms unfolding isolated_in_def by auto

lemma isolated_inE:
  assumes "x isolated_in S"
  obtains T where "x \<in> S" "open T" "T \<inter> S = {x}"
  using assms that unfolding isolated_in_def by force

lemma isolated_inE_dist:
  assumes "x isolated_in S"
  obtains d where "d > 0" "\<And>y. y \<in> S \<Longrightarrow> dist x y < d \<Longrightarrow> y = x"
  by (meson assms isolated_in_dist_Ex_iff)

lemma isolated_in_altdef:
  "x isolated_in S \<longleftrightarrow> (x\<in>S \<and> eventually (\<lambda>y. y \<notin> S) (at x))"
proof
  assume "x isolated_in S"
  from isolated_inE[OF this]
  obtain T where "x \<in> S" and T:"open T" "T \<inter> S = {x}"
    by metis
  have "\<forall>\<^sub>F y in nhds x. y \<in> T"
    apply (rule eventually_nhds_in_open)
    using T by auto
  then have  "eventually (\<lambda>y. y \<in> T - {x}) (at x)"
    unfolding eventually_at_filter by eventually_elim auto
  then have "eventually (\<lambda>y. y \<notin> S) (at x)"
    by eventually_elim (use T in auto)
  then show " x \<in> S \<and> (\<forall>\<^sub>F y in at x. y \<notin> S)" using \<open>x \<in> S\<close> by auto
next
  assume "x \<in> S \<and> (\<forall>\<^sub>F y in at x. y \<notin> S)"
  then have "\<forall>\<^sub>F y in at x. y \<notin> S" "x\<in>S" by auto
  from this(1) have "eventually (\<lambda>y. y \<notin> S \<or> y = x) (nhds x)"
    unfolding eventually_at_filter by eventually_elim auto
  then obtain T where T:"open T" "x \<in> T" "(\<forall>y\<in>T. y \<notin> S \<or> y = x)"
    unfolding eventually_nhds by auto
  with \<open>x \<in> S\<close> have "T \<inter> S = {x}"
    by fastforce
  with \<open>x\<in>S\<close> \<open>open T\<close>
  show "x isolated_in S"
    unfolding isolated_in_def by auto
qed

lemma discrete_altdef:
  "discrete S \<longleftrightarrow> (\<forall>x\<in>S. \<forall>\<^sub>F y in at x. y \<notin> S)"
  unfolding discrete_def isolated_in_altdef by auto

(*
TODO.
Other than

  uniform_discrete S \<longrightarrow> discrete S
  uniform_discrete S \<longrightarrow> closed S

, we should be able to prove

  discrete S \<and> closed S \<longrightarrow> uniform_discrete S

but the proof (based on Tietze Extension Theorem) seems not very trivial to me. Informal proofs can be found in

http://topology.auburn.edu/tp/reprints/v30/tp30120.pdf
http://msp.org/pjm/1959/9-2/pjm-v9-n2-p19-s.pdf
*)

lemma uniform_discrete_imp_closed:
  "uniform_discrete S \<Longrightarrow> closed S"
  by (meson discrete_imp_closed uniform_discrete_def)

lemma uniform_discrete_imp_discrete:
  "uniform_discrete S \<Longrightarrow> discrete S"
  by (metis discrete_def isolated_in_dist_Ex_iff uniform_discrete_def)

lemma isolated_in_subset:"x isolated_in S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> x\<in>T \<Longrightarrow> x isolated_in T"
  unfolding isolated_in_def by fastforce

lemma discrete_subset[elim]: "discrete S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> discrete T"
  unfolding discrete_def using islimpt_subset isolated_in_islimpt_iff by blast

lemma uniform_discrete_subset[elim]: "uniform_discrete S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> uniform_discrete T"
  by (meson subsetD uniform_discrete_def)

lemma continuous_on_discrete: "discrete S \<Longrightarrow> continuous_on S f"
  unfolding continuous_on_topological by (metis discrete_def islimptI isolated_in_islimpt_iff)

lemma uniform_discrete_insert: "uniform_discrete (insert a S) \<longleftrightarrow> uniform_discrete S"
proof
  assume asm:"uniform_discrete S"
  let ?thesis = "uniform_discrete (insert a S)"
  have ?thesis when "a\<in>S" using that asm by (simp add: insert_absorb)
  moreover have ?thesis when "S={}" using that asm by (simp add: uniform_discrete_def)
  moreover have ?thesis when "a\<notin>S" "S\<noteq>{}"
  proof -
    obtain e1 where "e1>0" and e1_dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist y x < e1 \<longrightarrow> y = x"
      using asm unfolding uniform_discrete_def by auto
    define e2 where "e2 \<equiv> min (setdist {a} S) e1"
    have "closed S" using asm uniform_discrete_imp_closed by auto
    then have "e2>0"
      by (smt (verit) \<open>0 < e1\<close> e2_def infdist_eq_setdist infdist_pos_not_in_closed that)
    moreover have "x = y" if "x\<in>insert a S" "y\<in>insert a S" "dist x y < e2" for x y
    proof (cases "x=a \<or> y=a")
      case True then show ?thesis
        by (smt (verit, best) dist_commute e2_def infdist_eq_setdist infdist_le insertE that)
    next
      case False then show ?thesis
        using e1_dist e2_def that by force
    qed
    ultimately show ?thesis unfolding uniform_discrete_def by meson
  qed
  ultimately show ?thesis by auto
qed (simp add: subset_insertI uniform_discrete_subset)

lemma discrete_compact_finite_iff:
  fixes S :: "'a::t1_space set"
  shows "discrete S \<and> compact S \<longleftrightarrow> finite S"
proof
  assume "finite S"
  then have "compact S" using finite_imp_compact by auto
  moreover have "discrete S"
    unfolding discrete_def using isolated_in_islimpt_iff islimpt_finite[OF \<open>finite S\<close>] by auto
  ultimately show "discrete S \<and> compact S" by auto
next
  assume "discrete S \<and> compact S"
  then show "finite S"
    by (meson discrete_def Heine_Borel_imp_Bolzano_Weierstrass isolated_in_islimpt_iff order_refl)
qed

lemma uniform_discrete_finite_iff:
  fixes S :: "'a::heine_borel set"
  shows "uniform_discrete S \<and> bounded S \<longleftrightarrow> finite S"
proof
  assume "uniform_discrete S \<and> bounded S"
  then have "discrete S" "compact S"
    using uniform_discrete_imp_discrete uniform_discrete_imp_closed compact_eq_bounded_closed
    by auto
  then show "finite S" using discrete_compact_finite_iff by auto
next
  assume asm:"finite S"
  let ?thesis = "uniform_discrete S \<and> bounded S"
  have ?thesis when "S={}" using that by auto
  moreover have ?thesis when "S\<noteq>{}"
  proof -
    have "\<forall>x. \<exists>d>0. \<forall>y\<in>S. y \<noteq> x \<longrightarrow> d \<le> dist x y"
      using finite_set_avoid[OF \<open>finite S\<close>] by auto
    then obtain f where f_pos:"f x>0"
        and f_dist: "\<forall>y\<in>S. y \<noteq> x \<longrightarrow> f x \<le> dist x y"
        if "x\<in>S" for x
      by metis
    define f_min where "f_min \<equiv> Min (f ` S)"
    have "f_min > 0"
      unfolding f_min_def
      by (simp add: asm f_pos that)
    moreover have "\<forall>x\<in>S. \<forall>y\<in>S. f_min > dist x y \<longrightarrow> x=y"
      using f_dist unfolding f_min_def
      by (metis Min_le asm finite_imageI imageI le_less_trans linorder_not_less)
    ultimately have "uniform_discrete S"
      unfolding uniform_discrete_def by auto
    moreover have "bounded S" using \<open>finite S\<close> by auto
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis by blast
qed

lemma uniform_discrete_image_scale:
  assumes "uniform_discrete S" and dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist x y = c * dist (f x) (f y)"
  shows "uniform_discrete (f ` S)"
proof -
  have ?thesis when "S={}" using that by auto
  moreover have ?thesis when "S\<noteq>{}" "c\<le>0"
  proof -
    obtain x1 where "x1\<in>S" using \<open>S\<noteq>{}\<close> by auto
    have ?thesis when "S-{x1} = {}"
      using \<open>x1 \<in> S\<close> subset_antisym that uniform_discrete_insert by fastforce
    moreover have ?thesis when "S-{x1} \<noteq> {}"
    proof -
      obtain x2 where "x2\<in>S-{x1}" using \<open>S-{x1} \<noteq> {}\<close> by auto
      then have "x2\<in>S" "x1\<noteq>x2" by auto
      then have "dist x1 x2 > 0" by auto
      moreover have "dist x1 x2 = c * dist (f x1) (f x2)"
        by (simp add: \<open>x1 \<in> S\<close> \<open>x2 \<in> S\<close> dist)
      moreover have "dist (f x2) (f x2) \<ge> 0" by auto
      ultimately have False using \<open>c\<le>0\<close> by (simp add: zero_less_mult_iff)
      then show ?thesis by auto
    qed
    ultimately show ?thesis by auto
  qed
  moreover have ?thesis when "S\<noteq>{}" "c>0"
  proof -
    obtain e1 where "e1>0" and e1_dist:"\<forall>x\<in>S. \<forall>y\<in>S. dist y x < e1 \<longrightarrow> y = x"
      using \<open>uniform_discrete S\<close> unfolding uniform_discrete_def by auto
    define e where "e \<equiv> e1/c"
    have "x1 = x2" when "x1 \<in> f ` S" "x2 \<in> f ` S" and d: "dist x1 x2 < e" for x1 x2
      by (smt (verit) \<open>0 < c\<close> d dist divide_right_mono e1_dist e_def imageE nonzero_mult_div_cancel_left that)
    moreover have "e>0" using \<open>e1>0\<close> \<open>c>0\<close> unfolding e_def by auto
    ultimately show ?thesis unfolding uniform_discrete_def by meson
  qed
  ultimately show ?thesis by fastforce
qed

definition sparse :: "real \<Rightarrow> 'a :: metric_space set \<Rightarrow> bool"
  where "sparse \<epsilon> X \<longleftrightarrow> (\<forall>x\<in>X. \<forall>y\<in>X-{x}. dist x y > \<epsilon>)"

lemma sparse_empty [simp, intro]: "sparse \<epsilon> {}"
  by (auto simp: sparse_def)

lemma sparseI [intro?]:
  "(\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<noteq> y \<Longrightarrow> dist x y > \<epsilon>) \<Longrightarrow> sparse \<epsilon> X"
  unfolding sparse_def by auto

lemma sparseD:
  "sparse \<epsilon> X \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<noteq> y \<Longrightarrow> dist x y > \<epsilon>"
  unfolding sparse_def by auto

lemma sparseD':
  "sparse \<epsilon> X \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> dist x y \<le> \<epsilon> \<Longrightarrow> x = y"
  unfolding sparse_def by force

lemma sparse_singleton [simp, intro]: "sparse \<epsilon> {x}"
  by (auto simp: sparse_def)

definition setdist_gt where "setdist_gt \<epsilon> X Y \<longleftrightarrow> (\<forall>x\<in>X. \<forall>y\<in>Y. dist x y > \<epsilon>)"

lemma setdist_gt_empty [simp]: "setdist_gt \<epsilon> {} Y" "setdist_gt \<epsilon> X {}"
  by (auto simp: setdist_gt_def)

lemma setdist_gtI: "(\<And>x y. x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> dist x y > \<epsilon>) \<Longrightarrow> setdist_gt \<epsilon> X Y"
  unfolding setdist_gt_def by auto

lemma setdist_gtD: "setdist_gt \<epsilon> X Y \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> dist x y > \<epsilon>"
  unfolding setdist_gt_def by auto

lemma setdist_gt_setdist: "\<epsilon> < setdist A B \<Longrightarrow> setdist_gt \<epsilon> A B"
  unfolding setdist_gt_def using setdist_le_dist by fastforce

lemma setdist_gt_mono: "setdist_gt \<epsilon>' A B \<Longrightarrow> \<epsilon> \<le> \<epsilon>' \<Longrightarrow> A' \<subseteq> A \<Longrightarrow> B' \<subseteq> B \<Longrightarrow> setdist_gt \<epsilon> A' B'"
  by (force simp: setdist_gt_def)

lemma setdist_gt_Un_left: "setdist_gt \<epsilon> (A \<union> B) C \<longleftrightarrow> setdist_gt \<epsilon> A C \<and> setdist_gt \<epsilon> B C"
  by (auto simp: setdist_gt_def)

lemma setdist_gt_Un_right: "setdist_gt \<epsilon> C (A \<union> B) \<longleftrightarrow> setdist_gt \<epsilon> C A \<and> setdist_gt \<epsilon> C B"
  by (auto simp: setdist_gt_def)

lemma compact_closed_imp_eventually_setdist_gt_at_right_0:
  assumes "compact A" "closed B" "A \<inter> B = {}"
  shows   "eventually (\<lambda>\<epsilon>. setdist_gt \<epsilon> A B) (at_right 0)"
proof (cases "A = {} \<or> B = {}")
  case False
  hence "setdist A B > 0"
    by (metis IntI assms empty_iff in_closed_iff_infdist_zero order_less_le setdist_attains_inf setdist_pos_le setdist_sym)
  hence "eventually (\<lambda>\<epsilon>. \<epsilon> < setdist A B) (at_right 0)"
    using eventually_at_right_field by blast
  thus ?thesis
    by eventually_elim (auto intro: setdist_gt_setdist)
qed auto

lemma setdist_gt_symI: "setdist_gt \<epsilon> A B \<Longrightarrow> setdist_gt \<epsilon> B A"
  by (force simp: setdist_gt_def dist_commute)

lemma setdist_gt_sym: "setdist_gt \<epsilon> A B \<longleftrightarrow> setdist_gt \<epsilon> B A"
  by (force simp: setdist_gt_def dist_commute)

lemma eventually_setdist_gt_at_right_0_mult_iff:
  assumes "c > 0"
  shows   "eventually (\<lambda>\<epsilon>. setdist_gt (c * \<epsilon>) A B) (at_right 0) \<longleftrightarrow>
             eventually (\<lambda>\<epsilon>. setdist_gt \<epsilon> A B) (at_right 0)"
proof -
  have "eventually (\<lambda>\<epsilon>. setdist_gt (c * \<epsilon>) A B) (at_right 0) \<longleftrightarrow>
        eventually (\<lambda>\<epsilon>. setdist_gt \<epsilon> A B) (filtermap ((*) c) (at_right 0))"
    by (simp add: eventually_filtermap)
  also have "filtermap ((*) c) (at_right 0) = at_right 0"
    by (subst filtermap_times_pos_at_right) (use assms in auto)
  finally show ?thesis .
qed

end


theory HoareLogicLecture
imports Main "HOL-Hoare.Hoare_Logic"
begin

lemma "VARS (z :: nat) (y::nat)
 {True}
 y := 1; z := 0;
 WHILE z \<noteq> x
 INV { y = fact z }
 DO
   z := z + 1;
   y := y * z
 OD
 {y = fact x}"
by vcg_simp

lemma "VARS (z :: int) i
 {True}
 i := y;
 z := 0;
 WHILE i \<noteq> 0
 INV { z = (y - i) * x }
 DO
   z := z + x;
   i := i - 1
 OD
 {z = x * y}"
apply vcg_simp
by (simp add: algebra_simps)

lemma "VARS j R
  { True }
  j:= 0; R := [];
  WHILE j < length A
  INV { R = rev (take j A) }
  DO
    R := (A!j) # R;
    j := j + 1
  OD
  { R = rev A }"
proof (vcg_simp)
  show "\<And>j R. R = rev (take j A) \<and> j < length A \<Longrightarrow> A ! j # rev (take j A) = rev (take (Suc j) A)"
  proof (induct A)
    case Nil thus ?case by simp
  next
    case (Cons a A') thus ?case by (cases "j", auto)
  qed
qed

lemma "VARS j R
  { True }
  j:= 0; R := [];
  WHILE j < length A
  INV { R = rev (take j A) }
  DO
    R := (A!j) # R;
    j := j + 1
  OD
  { R = rev A }"
proof (vcg_simp, simp add: take_Suc_conv_app_nth)
qed

end


section \<open>Combining Spectral Radius Theory with Perron Frobenius theorem\<close>

theory Spectral_Radius_Theory
imports
  Polynomial_Factorization.Square_Free_Factorization
  Jordan_Normal_Form.Spectral_Radius
  Jordan_Normal_Form.Char_Poly
  Perron_Frobenius
  "HOL-Computational_Algebra.Field_as_Ring"
begin
abbreviation spectral_radius where "spectral_radius \<equiv> Spectral_Radius.spectral_radius"
hide_const (open) Module.smult

text \<open>Via JNFs it has been proven that the growth of $A^k$ is polynomially bounded,
  if all complex eigenvalues have a norm at most 1, i.e., the spectral radius must be
  at most 1. Moreover, the degree of the polynomial growth can be
  bounded by the order of those roots which have norm 1, cf. @{thm spectral_radius_poly_bound}.\<close>

text \<open>Perron Frobenius theorem tells us that for a real valued non negative matrix,
  the largest eigenvalue is a real non-negative one. Hence, we only have to check, that all real
  eigenvalues are at most one.\<close>

text \<open>We combine both theorems in the following. To be more precise,
  the set-based complexity results from JNFs with the type-based
  Perron Frobenius theorem in HMA are connected to obtain
  a set based complexity criterion for real-valued
  non-negative matrices, where one only investigated the real valued eigenvalues for
  checking the eigenvalue-at-most-1 condition.
  Here, in the precondition of the roots of the polynomial, the type-system ensures
  that we only have to look at real-valued eigenvalues, and can ignore the
  complex-valued ones.

  The linkage between set-and type-based is performed via HMA-connect.\<close>

lemma perron_frobenius_spectral_radius_complex: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  and real_nonneg: "real_nonneg_mat A"
  and ev_le_1: "\<And> x. poly (char_poly (map_mat Re A)) x = 0 \<Longrightarrow> x \<le> 1"
  and ev_order: "\<And> x. norm x = 1 \<Longrightarrow> order x (char_poly A) \<le> d"
  shows "\<exists>c1 c2. \<forall>k. norm_bound (A ^\<^sub>m k) (c1 + c2 * real k ^ (d - 1))"
proof (cases "n = 0")
  case False
  hence n: "n > 0" "n \<noteq> 0" by auto
  define sr where "sr = spectral_radius A"
  note sr = spectral_radius_mem_max[OF A n(1), folded sr_def]
  show ?thesis
  proof (rule spectral_radius_poly_bound[OF A], unfold sr_def[symmetric])
    let ?cr = "complex_of_real"
    text \<open>here is the transition from type-based perron-frobenius to set-based\<close>
    from perron_frobenius[untransferred, cancel_card_constraint, OF A real_nonneg n(2)]
      obtain v where v: "v \<in> carrier_vec n" and ev: "eigenvector A v (?cr sr)" and
      rnn: "real_nonneg_vec v" unfolding sr_def by auto
    define B where "B = map_mat Re A"
    let ?A = "map_mat ?cr B"
    have AB: "A = ?A" unfolding B_def
      by (rule eq_matI, insert real_nonneg[unfolded real_nonneg_mat_def elements_mat_def], auto)
    define w where "w = map_vec Re v"
    let ?v = "map_vec ?cr w"
    have vw: "v = ?v" unfolding w_def
      by (rule eq_vecI, insert rnn[unfolded real_nonneg_vec_def vec_elements_def], auto)
    have B: "B \<in> carrier_mat n n" unfolding B_def using A by auto
    from AB vw ev have ev: "eigenvector ?A ?v (?cr sr)" by simp
    have "eigenvector B w sr"
      by (rule of_real_hom.eigenvector_hom_rev[OF B ev])
    hence "eigenvalue B sr" unfolding eigenvalue_def by blast
    from ev_le_1[folded B_def, OF this[unfolded eigenvalue_root_char_poly[OF B]]]
    show "sr \<le> 1" .
  next
    fix ev
    assume "cmod ev = 1"
    thus "order ev (char_poly A) \<le> d" by (rule ev_order)
  qed
next
  case True
  with A show ?thesis
    by (intro exI[of _ 0], auto simp: norm_bound_def)
qed

text \<open>The following lemma is the same as @{thm perron_frobenius_spectral_radius_complex},
  except that now the type @{typ real} is used instead of @{typ complex}.\<close>

lemma perron_frobenius_spectral_radius: fixes A :: "real mat"
  assumes A: "A \<in> carrier_mat n n"
  and nonneg: "nonneg_mat A"
  and ev_le_1: "\<forall> x. poly (char_poly A) x = 0 \<longrightarrow> x \<le> 1"
  and ev_order: "\<forall> x :: complex. norm x = 1 \<longrightarrow> order x (map_poly of_real (char_poly A)) \<le> d"
  shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> abs a \<le> (c1 + c2 * real k ^ (d - 1))"
proof -
  let ?cr = "complex_of_real"
  let ?B = "map_mat ?cr A"
  have B: "?B \<in> carrier_mat n n" using A by auto
  have rnn: "real_nonneg_mat ?B" using nonneg unfolding real_nonneg_mat_def nonneg_mat_def
    by (auto simp: elements_mat_def)
  have id: "map_mat Re ?B = A"
    by (rule eq_matI, auto)
  have "\<exists>c1 c2. \<forall>k. norm_bound (?B ^\<^sub>m k) (c1 + c2 * real k ^ (d - 1))"
    by (rule perron_frobenius_spectral_radius_complex[OF B rnn], unfold id,
    insert ev_le_1 ev_order, auto simp: of_real_hom.char_poly_hom[OF A])
  then obtain c1 c2 where nb: "\<And> k. norm_bound (?B ^\<^sub>m k) (c1 + c2 * real k ^ (d - 1))" by auto
  show ?thesis
  proof (rule exI[of _ c1], rule exI[of _ c2], intro allI impI)
    fix k a
    assume "a \<in> elements_mat (A ^\<^sub>m k)"
    with pow_carrier_mat[OF A] obtain i j where a: "a = (A ^\<^sub>m k) $$ (i,j)" and ij: "i < n" "j < n"
      unfolding elements_mat by force
    from ij nb[of k] A have "norm ((?B ^\<^sub>m k) $$ (i,j)) \<le> c1 + c2 * real k ^ (d - 1)"
      unfolding norm_bound_def by auto
    also have "(?B ^\<^sub>m k) $$ (i,j) = ?cr a"
      unfolding of_real_hom.mat_hom_pow[OF A, symmetric] a using ij A by auto
    also have "norm (?cr a) = abs a" by auto
    finally show "abs a \<le> (c1 + c2 * real k ^ (d - 1))" .
  qed
qed

text \<open>We can also convert the set-based lemma @{thm perron_frobenius_spectral_radius}
  to a type-based version.\<close>

text \<open>And of course, we can also transfer the type-based lemma back to a set-based setting,
  only that -- without further case-analysis --
  we get the additional assumption @{term "(n :: nat) \<noteq> 0"}.\<close>

lemma assumes "A \<in> carrier_mat n n"
  and "nonneg_mat A"
  and "\<forall> x. poly (char_poly A) x = 0 \<longrightarrow> x \<le> 1"
  and "\<forall> x :: complex. norm x = 1 \<longrightarrow> order x (map_poly of_real (char_poly A)) \<le> d"
  and "n \<noteq> 0"
  shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> abs a \<le> (c1 + c2 * real k ^ (d - 1))"
  using perron_frobenius_spectral_type_based[untransferred, cancel_card_constraint, OF assms] .

text \<open>Note that the precondition eigenvalue-at-most-1 can easily be formulated as a cardinality
  constraints which can be decided by Sturm's theorem.
  And in order to obtain a bound on the order, one can
  perform a square-free-factorization (via Yun's factorization algorithm)
  of the characteristic polynomial into
  $f_1^1 \cdot \ldots f_d^d$ where each $f_i$ has precisely the roots of order $i$.\<close>

context
  fixes A :: "real mat" and c :: real and fis and n :: nat
  assumes A: "A \<in> carrier_mat n n"
  and nonneg: "nonneg_mat A"
  and yun: "yun_factorization gcd (char_poly A) = (c,fis)"
  and ev_le_1: "card {x. poly (char_poly A) x = 0 \<and> x > 1} = 0"
begin

text \<open>Note that @{const yun_factorization} has an offset by 1,
  so the pair @{term "(f\<^sub>i,i) \<in> set fis"} encodes @{term "f\<^sub>i^(Suc i)"}.\<close>
lemma perron_frobenius_spectral_radius_yun:
  assumes bnd: "\<And> f\<^sub>i i. (f\<^sub>i,i) \<in> set fis
    \<Longrightarrow> (\<exists> x :: complex. poly (map_poly of_real f\<^sub>i) x = 0 \<and> norm x = 1)
    \<Longrightarrow> Suc i \<le> d"
  shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> abs a \<le> (c1 + c2 * real k ^ (d - 1))"
proof (rule perron_frobenius_spectral_radius[OF A nonneg]; intro allI impI)
  let ?cr = complex_of_real
  let ?cp = "map_poly ?cr (char_poly A)"
  fix x :: complex
  assume x: "norm x = 1"
  have A0: "char_poly A \<noteq> 0" using degree_monic_char_poly[OF A] by auto
  interpret field_hom_0' ?cr by (standard, auto)
  from A0 have cp0: "?cp \<noteq> 0" by auto
  obtain ox where ox: "order x ?cp = ox" by blast
  note sff = square_free_factorization_order_root[OF yun_factorization(1)[OF
    yun_factorization_hom[of "char_poly A", unfolded yun map_prod_def split]] cp0, of x ox, unfolded ox]
  show "order x ?cp \<le> d" unfolding ox
  proof (cases ox)
    case (Suc oo)
    with sff obtain fi where mem: "(fi,oo) \<in> set fis" and rt: "poly (map_poly ?cr fi) x = 0" by auto
    from bnd[OF mem exI[of _ x], OF conjI[OF rt x]]
    show "ox \<le> d" unfolding Suc .
  qed auto
next
  let ?L = "{x. poly (char_poly A) x = 0 \<and> x > 1}"
  fix x :: real
  assume rt: "poly (char_poly A) x = 0"
  have "finite ?L"
    by (rule finite_subset[OF _ poly_roots_finite[of "char_poly A"]],
      insert degree_monic_char_poly[OF A], auto)
  with ev_le_1 have "?L = {}" by simp
  with rt show "x \<le> 1" by auto
qed

text \<open>Note that the only remaining problem in applying
  @{thm perron_frobenius_spectral_radius_yun} is to check the
  condition @{term "\<exists> x :: complex. poly (map_poly of_real f\<^sub>i) x = 0 \<and> norm x = 1"}.
  Here, there are at least three possibilities.
  First, one can just ignore this precondition and weaken the statement.
  Second, one can apply Sturm's theorem to determine whether all roots are real.
  This can be done by comparing the number of distinct real roots with the degree of @{term f\<^sub>i},
    since @{term f\<^sub>i} is square-free. If all roots are real, then one can decide the criterion
    by checking the only two possible real roots with norm equal to 1, namely 1 and -1.
    If on the other hand there are complex roots, then we loose precision at this point.
  Third, one uses a factorization algorithm (e.g., via complex algebraic numbers) to
  precisely determine the complex roots and decide the condition.

  The second approach is illustrated in the following theorem. Note that all preconditions --
  including the ones from the context --
  can easily be checked with the help of Sturm's method.
  This method is used as a fast approximative technique in CeTA \cite{CeTA}. Only if the desired degree
  cannot be ensured by this method, the more costly complex algebraic number based
  factorization is applied.\<close>

lemma perron_frobenius_spectral_radius_yun_real_roots:
  assumes bnd: "\<And> f\<^sub>i i. (f\<^sub>i,i) \<in> set fis
    \<Longrightarrow> card { x. poly f\<^sub>i x = 0} \<noteq> degree f\<^sub>i \<or> poly f\<^sub>i 1 = 0 \<or> poly f\<^sub>i (-1) = 0
    \<Longrightarrow> Suc i \<le> d"
  shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> abs a \<le> (c1 + c2 * real k ^ (d - 1))"
proof (rule perron_frobenius_spectral_radius_yun)
  fix fi i
  let ?cr = complex_of_real
  let ?cp = "map_poly ?cr"
  assume fi: "(fi, i) \<in> set fis"
    and "\<exists> x. poly (map_poly ?cr fi) x = 0 \<and> norm x = 1"
  then obtain x where rt: "poly (?cp fi) x = 0" and x: "norm x = 1" by auto
  show "Suc i \<le> d"
  proof (rule bnd[OF fi])
    consider (c) "x \<notin> \<real>" | (1) "x = 1" | (m1) "x = -1" | (r) "x \<in> \<real>" "x \<notin> {1, -1}"
      by (cases "x \<in> \<real>"; auto)
    thus "card {x. poly fi x = 0} \<noteq> degree fi \<or> poly fi 1 = 0 \<or> poly fi (- 1) = 0"
    proof (cases)
      case 1
      from rt have "poly fi 1 = 0"
        unfolding 1 by simp
      thus ?thesis by simp
    next
      case m1
      have id: "-1 = ?cr (-1)" by simp
      from rt have "poly fi (-1) = 0"
        unfolding m1 id of_real_hom.hom_zero[where 'a=complex,symmetric] of_real_hom.poly_map_poly by simp
      thus ?thesis by simp
    next
      case r
      then obtain y where xy: "x = of_real y" unfolding Reals_def by auto
      from r(2)[unfolded xy] have y: "y \<notin> {1,-1}" by auto
      from x[unfolded xy] have "abs y = 1" by auto
      with y have False by auto
      thus ?thesis ..
    next
      case c
      from yun_factorization(2)[OF yun] fi have "monic fi" by auto
      hence fi: "?cp fi \<noteq> 0" by auto
      hence fin: "finite {x. poly (?cp fi) x = 0}" by (rule poly_roots_finite)
      have "?cr ` {x. poly (?cp fi) (?cr x) = 0} \<subset> {x. poly (?cp fi) x = 0}" (is "?l \<subset> ?r")
      proof (rule, force)
        have "x \<in> ?r" using rt by auto
        moreover have "x \<notin> ?l" using c unfolding Reals_def by auto
        ultimately show "?l \<noteq> ?r" by blast
      qed
      from psubset_card_mono[OF fin this] have "card ?l < card ?r" .
      also have "\<dots> \<le> degree (?cp fi)" by (rule poly_roots_degree[OF fi])
      also have "\<dots> = degree fi" by simp
      also have "?l = ?cr ` {x. poly fi x = 0}" by auto
      also have "card \<dots> = card {x. poly fi x = 0}"
        by (rule card_image, auto simp: inj_on_def)
      finally have "card {x. poly fi x = 0} \<noteq> degree fi" by simp
      thus ?thesis by auto
    qed
  qed
qed

end

thm perron_frobenius_spectral_radius_yun_real_roots
end


theory cases_playground
imports Main
begin

(* example simple custom bools *)

datatype mybool = T | F
print_theorems
thm mybool.induct

fun not :: "mybool \<Rightarrow> mybool" where
  "not T = F" |
  "not F = T"

lemma "not (not b) = b" apply (cases b) apply simp by simp

lemma
  shows "not (not b) = b"
proof (cases b)
case T
  then show ?thesis by simp
next
  case F
  then show ?thesis by simp
qed

(* example Inductively defined predicates *)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc(Suc n)) = evn n"

lemma
  shows "ev n \<Longrightarrow> evn n"
proof (induction rule: ev.induct)
  case ev0
  then show ?case by simp
next
  case (evSS n)
  then show ?case by simp
qed

(* failed to do it directly to it
lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof (cases n)
    case ev0 then show "ev (n - 2)" by (simp add: ev.ev0)
  next
    case (evSS n') then show "ev (n - 2)" by (simp add: ev.evSS)
  qed
qed
*)

lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof -
  assume 0: "ev n"
  from this show "ev (n - 2)"
  proof (cases)
    case ev0 then show "ev (n - 2)" by (simp add: ev.ev0)
  next
    case (evSS n') then show "ev (n - 2)" by (simp add: ev.evSS)
  qed
qed

lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof -
  assume 0: "ev n"
  from this show "ev (n - 2)"
  proof (cases)
    assume "n = 0"
    then show "ev (n - 2)" by (simp add: ev.ev0)
  next
    fix n'
    assume "n = Suc (Suc n')" "ev n'"
    then show "ev (n - 2)" by (simp add: ev.evSS)
  qed
qed

lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof -
  assume "ev n"
  from this show "ev (n - 2)"
  proof (cases)
    case ev0
    then show ?thesis using `ev n` by auto
  next
    case (evSS n)
    then show ?thesis by simp
  qed
qed

lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof -
  assume "ev n"
  from this show "ev (n - 2)"
  proof (cases rule: ev.cases)
    case ev0
    then show ?thesis by (simp add: ev.ev0)
  next
    case (evSS n)
    then show ?thesis by simp
  qed
qed

(* failed to unify manually for the argument ev ?a *)
lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof (cases rule: ev.cases)
  show ?thesis by sorry
  show ?thesis by sorry
  show ?thesis by sorry
qed

lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof (rule ev.cases)
  show ?thesis by sorry
  show ?thesis by sorry
  show ?thesis by sorry
qed

(* but the manual unifications succeds here though *)
lemma "ev n \<Longrightarrow> ev (n - 2)"
  thm ev.cases
  apply (cases rule: ev.cases)
    apply simp
   apply simp
  by simp

thm ev.induct ev.cases
(*
Note that induction and cases is very similar except that induction introduces
the induction hypothesis after doing the unification, the ?Pn in this example.
  ev ?x \<Longrightarrow> ?P 0 \<Longrightarrow> (\<And>n. ev n \<Longrightarrow> ?P n \<Longrightarrow> ?P (Suc (Suc n))) \<Longrightarrow> ?P ?x
  ev ?a \<Longrightarrow> (?a = 0 \<Longrightarrow> ?P) \<Longrightarrow> (\<And>n. ?a = Suc (Suc n) \<Longrightarrow> ev n \<Longrightarrow> ?P) \<Longrightarrow> ?P
*)

(* this does the unification for me *)
lemma
  shows "ev n \<Longrightarrow> ev (n - 2)"
proof (cases)
  show ?thesis by sorry
  show ?thesis by sorry
qed

(* Construct clashes *)

lemma
  shows "\<not> ev (Suc 0)"
proof (rule notI)
  assume "ev (Suc 0)"
  then show False
  proof
    show "Suc 0 = 0 \<Longrightarrow> False" by simp
    show "\<And>n. \<lbrakk>Suc 0 = Suc (Suc n); ev n\<rbrakk> \<Longrightarrow> False" by simp
  qed
qed

lemma
  shows "ev (Suc 0) \<Longrightarrow> P"
proof (cases P)
  case True
  then show ?thesis by assumption
next
  case False
  then show ?thesis
  qed

lemma
  shows "\<not> ev (Suc 0)"
proof (rule notI)
  assume "ev (Suc 0)"
  then show False
  proof (cases)
  case ev0
    then show ?case by blast
  next
    case evSS
    then show ?case sorry
qed

end