(* Title:      Extended Designs
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Extended Designs\<close>

theory Extended_Designs

imports Omega_Algebras Domain

begin

class domain_semiring_L_below = left_zero_domain_semiring + L +
  assumes L_left_zero_below: "L * x \<le> L"
  assumes mult_L_split: "x * L = x * bot \<squnion> d(x) * L"
begin

lemma d_zero_mult_L:
  "d(x * bot) * L \<le> x"
  by (metis le_sup_iff mult_L_split mult_assoc mult_left_zero zero_right_mult_decreasing)

lemma mult_L:
  "x * L \<le> x * bot \<squnion> L"
  by (metis sup_right_isotone d_mult_below mult_L_split)

lemma d_mult_L:
  "d(x) * L \<le> x * L"
  by (metis sup_right_divisibility mult_L_split)

lemma d_L_split:
  "x * d(y) * L = x * bot \<squnion> d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero mult_L_split mult_assoc mult_left_zero)

lemma d_mult_mult_L:
  "d(x * y) * L \<le> x * d(y) * L"
  using d_L_split by auto

lemma L_L:
  "L * L = L"
  by (metis d_restrict_equals le_iff_sup mult_L_split zero_right_mult_decreasing)

end

class antidomain_semiring_L = left_zero_antidomain_semiring + L +
  assumes d_zero_mult_L: "d(x * bot) * L \<le> x"
  assumes d_L_zero     : "d(L * bot) = 1"
  assumes mult_L       : "x * L \<le> x * bot \<squnion> L"
begin

lemma L_left_zero:
  "L * x = L"
  by (metis order.antisym d_L_zero d_zero_mult_L mult_assoc mult_left_one mult_left_zero zero_right_mult_decreasing)

subclass domain_semiring_L_below
  apply unfold_locales
  apply (simp add: L_left_zero)
  apply (rule order.antisym)
  apply (smt d_restrict_equals le_iff_sup mult_L mult_assoc mult_left_dist_sup)
  by (metis le_sup_iff d_L_zero d_mult_d d_zero_mult_L mult_assoc mult_right_isotone mult_1_right bot_least)

end

class ed_below = bounded_left_zero_omega_algebra + domain_semiring_L_below + Omega +
  assumes Omega_def: "x\<^sup>\<Omega> = d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star>"
begin

lemma Omega_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<Omega> \<le> y\<^sup>\<Omega>"
  by (metis Omega_def sup_mono d_isotone mult_left_isotone omega_isotone star.circ_isotone)

lemma star_below_Omega:
  "x\<^sup>\<star> \<le> x\<^sup>\<Omega>"
  using Omega_def by auto

lemma one_below_Omega:
  "1 \<le> x\<^sup>\<Omega>"
  using order_trans star.circ_reflexive star_below_Omega by blast

lemma L_left_zero_star:
  "L * x\<^sup>\<star> = L"
  by (meson L_left_zero_below order.antisym star.circ_back_loop_prefixpoint sup.boundedE)

lemma L_left_zero_Omega:
  "L * x\<^sup>\<Omega> = L"
  using L_left_zero_star L_left_zero_below Omega_def mult_left_dist_sup sup.order_iff sup_monoid.add_commute by auto

lemma mult_L_star:
  "(x * L)\<^sup>\<star> = 1 \<squnion> x * L"
  by (metis L_left_zero_star mult_assoc star.circ_left_unfold)

lemma mult_L_omega_below:
  "(x * L)\<^sup>\<omega> \<le> x * L"
  by (metis L_left_zero_below mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
  by (metis L_left_zero_star sup_commute mult_assoc star.circ_unfold_sum)

lemma mult_L_sup_omega_below:
  "(x * L \<squnion> y)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have "(x * L \<squnion> y)\<^sup>\<omega> = (y\<^sup>\<star> * x * L)\<^sup>\<omega> \<squnion> (y\<^sup>\<star> * x * L)\<^sup>\<star> * y\<^sup>\<omega>"
    by (simp add: ils.il_inf_associative omega_decompose sup_commute)
  also have "... \<le> y\<^sup>\<star> * x * L \<squnion> (y\<^sup>\<star> * x * L)\<^sup>\<star> * y\<^sup>\<omega>"
    using sup_left_isotone mult_L_omega_below by auto
  also have "... = y\<^sup>\<star> * x * L \<squnion> y\<^sup>\<star> * x * L * y\<^sup>\<omega> \<squnion> y\<^sup>\<omega>"
    by (smt L_left_zero_star sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint)
  also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (metis L_left_zero_star sup_commute eq_refl mult_assoc star.circ_back_loop_fixpoint)
  finally show ?thesis
    .
qed

lemma mult_L_sup_circ:
  "(x * L \<squnion> y)\<^sup>\<Omega> = d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have "(x * L \<squnion> y)\<^sup>\<Omega> = d((x * L \<squnion> y)\<^sup>\<omega>) * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (simp add: Omega_def)
  also have "... \<le> d(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L) * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (metis sup_left_isotone d_isotone mult_L_sup_omega_below mult_left_isotone)
  also have "... = d(y\<^sup>\<omega>) * L \<squnion> d(y\<^sup>\<star> * x * L) * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (simp add: d_dist_sup mult_right_dist_sup)
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * x * L * L \<squnion> (x * L \<squnion> y)\<^sup>\<star>"
    by (meson d_mult_L order.refl sup.mono)
  also have "... = d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (smt L_L sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_assoc order_refl)
  finally have 1: "(x * L \<squnion> y)\<^sup>\<Omega> \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    .
  have 2: "d(y\<^sup>\<omega>) * L \<le> (x * L \<squnion> y)\<^sup>\<Omega>"
    using Omega_isotone Omega_def by force
  have "y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L \<le> (x * L \<squnion> y)\<^sup>\<Omega>"
    by (metis Omega_def sup_ge2 mult_L_sup_star)
  hence "d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L \<le> (x * L \<squnion> y)\<^sup>\<Omega>"
    using 2 by simp
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

lemma circ_sup_d:
  "(x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega> = d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L)"
proof -
  have "(x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega> = ((d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star>) * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    by (simp add: Omega_def)
  also have "... = (d(x\<^sup>\<omega>) * L * y \<squnion> x\<^sup>\<star> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    by (simp add: mult_right_dist_sup)
  also have "... \<le> (d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    by (metis L_left_zero_below Omega_isotone sup_left_isotone mult_assoc mult_left_isotone mult_right_isotone)
  also have "... = (d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L) * x\<^sup>\<Omega>"
    by (simp add: mult_L_sup_circ)
  also have "... = d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L * x\<^sup>\<Omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<Omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L * x\<^sup>\<Omega>"
    using mult_right_dist_sup by auto
  also have "... = d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<Omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L"
    by (simp add: L_left_zero_Omega mult.assoc)
  also have "... = d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L)"
    by (simp add: Omega_def ils.il_inf_associative semiring.distrib_left sup_left_commute sup_monoid.add_commute)
  finally have 1: "(x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega> \<le> d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L)"
    .
  have "d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega>"
    using Omega_isotone Omega_def mult_left_isotone by auto
  also have "... \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    by (metis mult_right_isotone mult_1_right one_below_Omega)
  finally have 2: "d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    .
  have 3: "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    by (meson Omega_isotone order.trans mult_left_isotone mult_right_isotone star_below_Omega)
  have "(x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L \<le> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<Omega>"
    by (metis Omega_def sup_commute mult_assoc mult_left_sub_dist_sup_right)
  also have "... \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    using Omega_isotone Omega_def mult_left_isotone by force
  finally have "d((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * d(x\<^sup>\<omega>) * L) \<le> (x\<^sup>\<Omega> * y)\<^sup>\<Omega> * x\<^sup>\<Omega>"
    using 2 3 by (simp add: sup_assoc)
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

proposition mult_L_omega: "(x * L)\<^sup>\<omega> = x * L" nitpick [expect=genuine,card=5] oops
proposition mult_L_sup_omega: "(x * L \<squnion> y)\<^sup>\<omega> = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L" nitpick [expect=genuine,card=5] oops
proposition d_Omega_circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<Omega> * z \<squnion> w \<Longrightarrow> z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)" nitpick [expect=genuine,card=4] oops
proposition d_Omega_circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<Omega> \<squnion> w \<Longrightarrow> x\<^sup>\<Omega> * z \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>" nitpick [expect=genuine,card=3] oops

end

class ed = ed_below +
  assumes L_left_zero: "L * x = L"
begin

lemma mult_L_omega:
  "(x * L)\<^sup>\<omega> = x * L"
  by (metis L_left_zero omega_slide)

lemma mult_L_sup_omega:
  "(x * L \<squnion> y)\<^sup>\<omega> = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
  by (metis L_left_zero ils.il_inf_associative mult_bot_add_omega sup_commute)

lemma d_Omega_circ_simulate_right_plus:
  assumes "z * x \<le> y * y\<^sup>\<Omega> * z \<squnion> w"
    shows "z * x\<^sup>\<Omega> \<le> y\<^sup>\<Omega> * (z \<squnion> w * x\<^sup>\<Omega>)"
proof -
  have "z * x \<le> y * d(y\<^sup>\<omega>) * L * z \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    using assms Omega_def ils.il_inf_associative mult_right_dist_sup semiring.distrib_left by auto
  also have "... \<le> y * d(y\<^sup>\<omega>) * L \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    by (metis L_left_zero_below sup_commute sup_right_isotone mult_assoc mult_right_isotone)
  also have "... = y * bot \<squnion> d(y * y\<^sup>\<omega>) * L \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    by (simp add: d_L_split)
  also have "... = d(y\<^sup>\<omega>) * L \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup omega_unfold)
  finally have 1: "z * x \<le> d(y\<^sup>\<omega>) * L \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    .
  have "(d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>) * x = d(y\<^sup>\<omega>) * L * x \<squnion> y\<^sup>\<star> * z * x \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L * x \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star> * x"
    using mult_right_dist_sup by fastforce
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z * x \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L * x \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star> * x"
    by (metis L_left_zero_below sup_left_isotone mult_assoc mult_right_isotone)
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z * x \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star> * x"
    by (metis L_left_zero_below sup_commute sup_left_isotone mult_assoc mult_right_isotone)
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z * x \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (meson star.circ_back_loop_prefixpoint sup.boundedE sup_right_isotone)
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (d(y\<^sup>\<omega>) * L \<squnion> y * y\<^sup>\<star> * z \<squnion> w) \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    using 1 by (smt sup_left_isotone sup_right_isotone le_iff_sup mult_assoc mult_left_dist_sup)
  also have "... = d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * y * y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup d_L_split star.circ_back_loop_fixpoint star_mult_omega)
  also have "... \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    using mult_isotone order_refl semiring.add_right_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_right_isotone by auto
  finally have 2: "z * x\<^sup>\<star> \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (smt le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
  have "z * x * x\<^sup>\<omega> \<le> y * y\<^sup>\<star> * z * x\<^sup>\<omega> \<squnion> d(y\<^sup>\<omega>) * L * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<omega>"
    using 1 by (metis sup_commute mult_left_isotone mult_right_dist_sup)
  also have "... \<le> y * y\<^sup>\<star> * z * x\<^sup>\<omega> \<squnion> d(y\<^sup>\<omega>) * L \<squnion> w * x\<^sup>\<omega>"
    by (metis L_left_zero eq_refl ils.il_inf_associative)
  finally have "z * x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup omega_induct omega_unfold star.left_plus_circ)
  hence "z * x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
    by (metis sup_commute d_mult_L le_iff_sup mult_assoc mult_right_isotone omega_sub_vector order_trans star_mult_omega)
  hence "d(z * x\<^sup>\<omega>) * L \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L"
    by (smt sup_assoc sup_commute d_L_split d_dist_sup le_iff_sup mult_right_dist_sup)
  hence "z * d(x\<^sup>\<omega>) * L \<le> z * bot \<squnion> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L"
    using d_L_split sup_assoc sup_right_isotone by force
  also have "... \<le> y\<^sup>\<star> * z \<squnion> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L"
    by (smt sup_commute sup_left_isotone sup_ge1 order_trans star.circ_loop_fixpoint zero_right_mult_decreasing)
  finally have "z * d(x\<^sup>\<omega>) * L \<le> d(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * d(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (simp add: le_supI2 sup_commute)
  thus ?thesis
    using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed

lemma d_Omega_circ_simulate_left_plus:
  assumes "x * z \<le> z * y\<^sup>\<Omega> \<squnion> w"
    shows "x\<^sup>\<Omega> * z \<le> (z \<squnion> x\<^sup>\<Omega> * w) * y\<^sup>\<Omega>"
proof -
  have "x * (z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>) = x * z * d(y\<^sup>\<omega>) * L \<squnion> x * z * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup d_L_split omega_unfold)
  also have "... \<le> (z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> w) * d(y\<^sup>\<omega>) * L \<squnion> (z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> w) * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
  also have "... = z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> * d(y\<^sup>\<omega>) * L \<squnion> w * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> w * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
  also have "... = z * d(y\<^sup>\<omega>) * L \<squnion> w * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> w * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc d_L_split star_mult_omega zero_right_mult_decreasing)
  finally have "x * (z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>) \<le> z * d(y\<^sup>\<omega>) * L \<squnion> z * y\<^sup>\<star> \<squnion> d(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * d(y\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
  thus ?thesis
    by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed

end

text \<open>Theorem 2.5 and Theorem 50.4\<close>

sublocale ed < ed_omega: itering where circ = Omega
  apply unfold_locales
  apply (smt sup_assoc sup_commute sup_bot_left circ_sup_d Omega_def mult_left_dist_sup mult_right_dist_sup d_L_split d_dist_sup omega_decompose star.circ_sup_1 star.circ_slide)
  apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup d_L_split omega_slide star.circ_mult)
  using d_Omega_circ_simulate_right_plus apply blast
  by (simp add: d_Omega_circ_simulate_left_plus)

sublocale ed < ed_star: itering where circ = star ..

class ed_2 = ed_below + antidomain_semiring_L + Omega
begin

subclass ed
  apply unfold_locales
  by (rule L_left_zero)

end

end


(* Author: Thiemann *)

section \<open>The Jordan Blocks of the Spectral Radius are Largest\<close>

text \<open>Consider a non-negative real matrix, and consider any Jordan-block
  of any eigenvalues whose norm is the spectral radius. We prove that there is
  a Jordan block of the spectral radius which has the same size or is larger.\<close>

theory Spectral_Radius_Largest_Jordan_Block
imports
  Jordan_Normal_Form.Jordan_Normal_Form_Uniqueness
  Perron_Frobenius_General
  "HOL-Real_Asymp.Real_Asymp"
begin

lemma poly_asymp_equiv: "(\<lambda>x. poly p (real x)) \<sim>[at_top] (\<lambda>x. lead_coeff p * real x ^ (degree p))"
proof (cases "degree p = 0")
  case False
  hence lc: "lead_coeff p \<noteq> 0" by auto
  have 1: "1 = (\<Sum>n\<le>degree p. if n = degree p then (1 :: real) else 0)" by simp
  from False show ?thesis
  proof (intro asymp_equivI', unfold poly_altdef sum_divide_distrib,
      subst 1, intro tendsto_sum, goal_cases)
    case (1 n)
    hence "n = degree p \<or> n < degree p" by auto
    thus ?case
    proof
      assume "n = degree p"
      thus ?thesis using False lc
        by (simp, intro LIMSEQ_I exI[of _ "Suc 0"], auto)
    qed (insert False lc, real_asymp)
  qed
next
  case True
  then obtain c where p: "p = [:c:]" by (metis degree_eq_zeroE)
  show ?thesis unfolding p by simp
qed

lemma sum_root_unity: fixes x :: "'a :: {comm_ring,division_ring}"
  assumes "x^n = 1"
  shows "sum (\<lambda> i. x^i) {..< n} = (if x = 1 then of_nat n else 0)"
proof (cases "x = 1 \<or> n = 0")
  case x: False
  from x obtain m where n: "n = Suc m" by (cases n, auto)
  have id: "{..< n} = {0..m}" unfolding n by auto
  show ?thesis using assms x n unfolding id sum_gp by (auto simp: divide_inverse)
qed auto

lemma sum_root_unity_power_pos_implies_1:
  assumes sumpos: "\<And> k. Re (sum (\<lambda> i. b i * x i ^ k) I) > 0"
  and root_unity: "\<And> i. i \<in> I \<Longrightarrow> \<exists> d. d \<noteq> 0 \<and> x i ^ d = 1"
shows "1 \<in> x ` I"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence x: "i \<in> I \<Longrightarrow> x i \<noteq> 1" for i by auto
  from sumpos[of 0] have I: "finite I" "I \<noteq> {}"
    using sum.infinite by fastforce+
  have "\<forall> i. \<exists> d. i \<in> I \<longrightarrow> d \<noteq> 0 \<and> x i ^ d = 1" using root_unity by auto
  from choice[OF this] obtain d where d: "\<And> i. i \<in> I \<Longrightarrow> d i \<noteq> 0 \<and> x i ^ (d i) = 1" by auto
  define D where "D = prod d I"
  have D0: "0 < D" unfolding D_def
    by (rule prod_pos, insert d, auto)
  have "0 < sum (\<lambda> k. Re (sum (\<lambda> i. b i * x i ^ k) I)) {..< D}"
    by (rule sum_pos[OF _ _ sumpos], insert D0, auto)
  also have "\<dots> = Re (sum (\<lambda> k. sum (\<lambda> i. b i * x i ^ k) I) {..< D})" by auto
  also have "sum (\<lambda> k. sum (\<lambda> i. b i * x i ^ k) I) {..< D}
    = sum (\<lambda> i. sum (\<lambda> k. b i * x i ^ k) {..< D}) I" by (rule sum.swap)
  also have "\<dots> = sum (\<lambda> i. b i * sum (\<lambda> k. x i ^ k) {..< D}) I"
    by (rule sum.cong, auto simp: sum_distrib_left)
  also have "\<dots> = 0"
  proof (rule sum.neutral, intro ballI)
    fix i
    assume i: "i \<in> I"
    from d[OF this] x[OF this] have d: "d i \<noteq> 0" and rt_unity: "x i ^ d i = 1"
      and x: "x i \<noteq> 1" by auto
    have "\<exists> C. D = d i * C" unfolding D_def
      by (subst prod.remove[of _ i], insert i I, auto)
    then obtain C where D: "D = d i * C" by auto
    have image: "(\<And> x. f x = x) \<Longrightarrow> {..< D} = f ` {..< D}" for f by auto
    let ?g = "(\<lambda> (a,c). a + d i * c)"
    have "{..< D} = ?g ` (\<lambda> j. (j mod d i, j div d i)) ` {..< d i * C}"
      unfolding image_image split D[symmetric] by (rule image, insert d mod_mult_div_eq, blast)
    also have "(\<lambda> j. (j mod d i, j div d i)) ` {..< d i * C} = {..< d i} \<times> {..< C}" (is "?f ` ?A = ?B")
    proof -
      {
        fix x
        assume "x \<in> ?B" then obtain a c where x: "x = (a,c)" and a: "a < d i" and c: "c < C" by auto
        hence "a + c * d i < d i * (1 + c)" by simp
        also have "\<dots> \<le> d i * C" by (rule mult_le_mono2, insert c, auto)
        finally have "a + c * d i \<in> ?A" by auto
        hence "?f (a + c * d i) \<in> ?f ` ?A" by blast
        also have "?f (a + c * d i) = x" unfolding x using a by auto
        finally have "x \<in> ?f ` ?A" .
      }
      thus ?thesis using d by (auto simp: div_lt_nat)
    qed
    finally have D: "{..< D} = (\<lambda> (a,c). a + d i * c) ` ?B" by auto
    have inj: "inj_on ?g ?B"
    proof -
      {
        fix a1 a2 c1 c2
        assume id: "?g (a1,c1) = ?g (a2,c2)" and *: "(a1,c1) \<in> ?B" "(a2,c2) \<in> ?B"
        from arg_cong[OF id, of "\<lambda> x. x div d i"] * have c: "c1 = c2" by auto
        from arg_cong[OF id, of "\<lambda> x. x mod d i"] * have a: "a1 = a2" by auto
        note a c
      }
      thus ?thesis by (smt SigmaE inj_onI)
    qed
    have "sum (\<lambda> k. x i ^ k) {..< D} = sum (\<lambda> (a,c). x i ^ (a + d i * c)) ?B"
      unfolding D by (subst sum.reindex, rule inj, auto intro!: sum.cong)
    also have "\<dots> = sum (\<lambda> (a,c). x i ^ a) ?B"
      by (rule sum.cong, auto simp: power_add power_mult rt_unity)
    also have "\<dots> = 0" unfolding sum.cartesian_product[symmetric]  sum.swap[of _ "{..<C}"]
      by (rule sum.neutral, intro ballI, subst sum_root_unity[OF rt_unity], insert x, auto)
    finally
    show "b i * sum (\<lambda> k. x i ^ k) {..< D} = 0" by simp
  qed
  finally show False by simp
qed

fun j_to_jb_index :: "(nat \<times> 'a)list \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "j_to_jb_index ((n,a) # n_as) i = (if i < n then (0,i) else
     let rec = j_to_jb_index n_as (i - n) in (Suc (fst rec), snd rec))"

fun jb_to_j_index :: "(nat \<times> 'a)list \<Rightarrow> nat \<times> nat \<Rightarrow> nat" where
  "jb_to_j_index n_as (0,j) = j"
| "jb_to_j_index ((n,_) # n_as) (Suc i, j) = n + jb_to_j_index n_as (i,j)"

lemma j_to_jb_index: assumes "i < sum_list (map fst n_as)"
  and "j < sum_list (map fst n_as)"
  and "j_to_jb_index n_as i = (bi, li)"
  and "j_to_jb_index n_as j = (bj, lj)"
  and "n_as ! bj = (n, a)"
shows "((jordan_matrix n_as) ^\<^sub>m r) $$ (i,j) = (if bi = bj then ((jordan_block n a) ^\<^sub>m r) $$ (li, lj) else 0)
  \<and> (bi = bj \<longrightarrow> li < n \<and> lj < n \<and> bj < length n_as \<and> (n,a) \<in> set n_as)"
  unfolding jordan_matrix_pow using assms
proof (induct n_as arbitrary: i j bi bj)
  case (Cons mb n_as i j bi bj)
  obtain m b where mb: "mb = (m,b)" by force
  note Cons = Cons[unfolded mb]
  have [simp]: "dim_col (case x of (n, a) \<Rightarrow> 1\<^sub>m n) = fst x" for x by (cases x, auto)
  have [simp]: "dim_row (case x of (n, a) \<Rightarrow> 1\<^sub>m n) = fst x" for x by (cases x, auto)
  have [simp]: "dim_col (case x of (n, a) \<Rightarrow> jordan_block n a ^\<^sub>m r) = fst x" for x by (cases x, auto)
  have [simp]: "dim_row (case x of (n, a) \<Rightarrow> jordan_block n a ^\<^sub>m r) = fst x" for x by (cases x, auto)
  consider (UL) "i < m" "j < m" | (UR) "i < m" "j \<ge> m" | (LL) "i \<ge> m" "j < m"
    | (LR) "i \<ge> m" "j \<ge> m" by linarith
  thus ?case
  proof cases
    case UL
    with Cons(2-) show ?thesis unfolding mb by (auto simp: Let_def)
  next
    case UR
    with Cons(2-) show ?thesis unfolding mb by (auto simp: Let_def dim_diag_block_mat o_def)
  next
    case LL
    with Cons(2-) show ?thesis unfolding mb by (auto simp: Let_def dim_diag_block_mat o_def)
  next
    case LR
    let ?i = "i - m"
    let ?j = "j - m"
    from LR Cons(2-) have bi: "j_to_jb_index n_as ?i = (bi - 1, li)" "bi \<noteq> 0" by (auto simp: Let_def)
    from LR Cons(2-) have bj: "j_to_jb_index n_as ?j = (bj - 1, lj)" "bj \<noteq> 0" by (auto simp: Let_def)
    from LR Cons(2-) have i: "?i < sum_list (map fst n_as)" by auto
    from LR Cons(2-) have j: "?j < sum_list (map fst n_as)" by auto
    from LR Cons(2-) bj(2) have nas: "n_as ! (bj - 1) = (n, a)" by (cases bj, auto)
    from bi(2) bj(2) have id: "(bi - 1 = bj - 1) = (bi = bj)" by auto
    note IH = Cons(1)[OF i j bi(1) bj(1) nas, unfolded id]
    have id: "diag_block_mat (map (\<lambda>a. case a of (n, a) \<Rightarrow> jordan_block n a ^\<^sub>m r) (mb # n_as)) $$ (i, j)
      = diag_block_mat (map (\<lambda>a. case a of (n, a) \<Rightarrow> jordan_block n a ^\<^sub>m r) n_as) $$ (?i, ?j)"
      using i j LR unfolding mb by (auto simp: Let_def dim_diag_block_mat o_def)
    show ?thesis using IH unfolding id by auto
  qed
qed auto

lemma j_to_jb_index_rev: assumes j: "j_to_jb_index n_as i = (bi, li)"
  and i: "i < sum_list (map fst n_as)"
  and k: "k \<le> li"
shows "li \<le> i \<and> j_to_jb_index n_as (i - k) = (bi, li - k) \<and> (
  j_to_jb_index n_as j = (bi,li - k) \<longrightarrow> j < sum_list (map fst n_as) \<longrightarrow> j = i - k)"
  using j i
proof (induct n_as arbitrary: i bi j)
  case (Cons mb n_as i bi j)
  obtain m b where mb: "mb = (m,b)" by force
  note Cons = Cons[unfolded mb]
  show ?case
  proof (cases "i < m")
    case True
    thus ?thesis unfolding mb using Cons(2-) by (auto simp: Let_def)
  next
    case i_large: False
    let ?i = "i - m"
    have i: "?i < sum_list (map fst n_as)" using Cons(2-) i_large by auto
    from Cons(2-) i_large have j: "j_to_jb_index n_as ?i = (bi - 1, li)"
      and bi: "bi \<noteq> 0" by (auto simp: Let_def)
    note IH = Cons(1)[OF j i]
    from IH have IH1: "j_to_jb_index n_as (i - m - k) = (bi - 1, li - k)" and
       li: "li \<le> i - m" by auto
    from li have aim1: "li \<le> i" by auto
    from li k i_large have "i - k \<ge> m" by auto
    hence aim2: "j_to_jb_index (mb # n_as) (i - k) = (bi, li - k)"
      using IH1 bi by (auto simp: mb Let_def add.commute)
    {
      assume *: "j_to_jb_index (mb # n_as) j = (bi, li - k)"
        "j < sum_list (map fst (mb # n_as))"
      from * bi have j: "j \<ge> m" unfolding mb by (auto simp: Let_def split: if_splits)
      let ?j = "j - m"
      from j * have jj: "?j < sum_list (map fst n_as)" unfolding mb by auto
      from j * have **: "j_to_jb_index n_as (j - m) = (bi - 1, li - k)" using bi mb
        by (cases "j_to_jb_index n_as (j - m)", auto simp: Let_def)
      from IH[of ?j] jj ** have "j - m = i - m - k" by auto
      with j i_large k have "j = i - k" using \<open>m \<le> i - k\<close> by linarith
    } note aim3 = this
    show ?thesis using aim1 aim2 aim3 by blast
  qed
qed auto

locale spectral_radius_1_jnf_max =
  fixes A :: "real mat" and n m :: nat and lam :: complex and n_as
  assumes A: "A \<in> carrier_mat n n"
  and nonneg: "nonneg_mat A"
  and jnf: "jordan_nf (map_mat complex_of_real A) n_as"
  and mem: "(m, lam) \<in> set n_as"
  and lam1: "cmod lam = 1"
  and sr1: "\<And>x. poly (char_poly A) x = 0 \<Longrightarrow> x \<le> 1"
  and max_block: "\<And> k la. (k,la) \<in> set n_as \<Longrightarrow> cmod la \<le> 1 \<and> (cmod la = 1 \<longrightarrow> k \<le> m)"
begin

lemma n_as0: "0 \<notin> fst ` set n_as"
  using jnf[unfolded jordan_nf_def] ..

lemma m0: "m \<noteq> 0" using mem n_as0 by force

abbreviation cA where "cA \<equiv> map_mat complex_of_real A"
abbreviation J where "J \<equiv> jordan_matrix n_as"

lemma sim_A_J: "similar_mat cA J"
  using jnf[unfolded jordan_nf_def] ..

lemma sumlist_nf: "sum_list (map fst n_as) = n"
proof -
  have "sum_list (map fst n_as) = dim_row (jordan_matrix n_as)" by simp
  also have "\<dots> = dim_row cA" using similar_matD[OF sim_A_J] by auto
  finally show ?thesis using A by auto
qed

definition p :: "nat \<Rightarrow> real poly" where
  "p s = (\<Prod>i = 0..<s. [: - of_nat i / of_nat (s - i), 1 / of_nat (s - i) :])"

lemma p_binom: assumes sk: "s \<le> k"
  shows "of_nat (k choose s) = poly (p s) (of_nat k)"
  unfolding binomial_altdef_of_nat[OF assms] p_def poly_prod
  by (rule prod.cong[OF refl], insert sk, auto simp: field_simps)

lemma p_binom_complex: assumes sk: "s \<le> k"
  shows "of_nat (k choose s) = complex_of_real (poly (p s) (of_nat k))"
  unfolding p_binom[OF sk, symmetric] by simp

lemma deg_p: "degree (p s) = s" unfolding p_def
  by (subst degree_prod_eq_sum_degree, auto)

lemma lead_coeff_p: "lead_coeff (p s) = (\<Prod>i = 0..<s. 1 / (of_nat s - of_nat i))"
  unfolding p_def lead_coeff_prod
  by (rule prod.cong[OF refl], auto)

lemma lead_coeff_p_gt_0: "lead_coeff (p s) > 0" unfolding lead_coeff_p
  by (rule prod_pos, auto)

definition "c = lead_coeff (p (m - 1))"

lemma c_gt_0: "c > 0" unfolding c_def by (rule lead_coeff_p_gt_0)
lemma c0: "c \<noteq> 0" using c_gt_0 by auto

definition PP where "PP = (SOME PP. similar_mat_wit cA J (fst PP) (snd PP))"
definition P where "P = fst PP"
definition iP where "iP = snd PP"

lemma JNF: "P \<in> carrier_mat n n" "iP \<in> carrier_mat n n" "J \<in> carrier_mat n n"
  "P * iP = 1\<^sub>m n" "iP * P = 1\<^sub>m n" "cA = P * J * iP"
proof (atomize (full), goal_cases)
  case 1
  have n: "n = dim_row cA" using A by auto
  from sim_A_J[unfolded similar_mat_def] obtain Q iQ
    where "similar_mat_wit cA J Q iQ" by auto
  hence "similar_mat_wit cA J (fst (Q,iQ)) (snd (Q,iQ))" by auto
  hence "similar_mat_wit cA J P iP" unfolding PP_def iP_def P_def
    by (rule someI)
  from similar_mat_witD[OF n this]
  show ?case by auto
qed

definition C :: "nat set" where
  "C = {j | j bj lj nn la. j < n \<and> j_to_jb_index n_as j = (bj, lj)
    \<and> n_as ! bj = (nn,la) \<and> cmod la = 1 \<and> nn = m \<and> lj = nn - 1}"

lemma C_nonempty: "C \<noteq> {}"
proof -
  from split_list[OF mem] obtain as bs where n_as: "n_as = as @ (m,lam) # bs" by auto
  let ?i = "sum_list (map fst as) + (m - 1)"
  have "j_to_jb_index n_as ?i = (length as, m - 1)"
    unfolding n_as by (induct as, insert m0, auto simp: Let_def)
  with lam1 have "?i \<in> C" unfolding C_def unfolding sumlist_nf[symmetric] n_as using m0 by auto
  thus ?thesis by blast
qed

lemma C_n: "C \<subseteq> {..<n}" unfolding C_def by auto

lemma root_unity_cmod_1: assumes la: "la \<in> snd ` set n_as" and 1: "cmod la = 1"
  shows "\<exists> d. d \<noteq> 0 \<and> la ^ d = 1"
proof -
  from la obtain k where kla: "(k,la) \<in> set n_as" by force
  from n_as0 kla have k0: "k \<noteq> 0" by force
  from split_list[OF kla] obtain as bs where nas: "n_as = as @ (k,la) # bs" by auto
  have rt: "poly (char_poly cA) la = 0" using k0
    unfolding jordan_nf_char_poly[OF jnf] nas poly_prod_list prod_list_zero_iff by auto
  obtain ks f where decomp: "decompose_prod_root_unity (char_poly A) = (ks, f)" by force
  from sumlist_nf[unfolded nas] k0 have n0: "n \<noteq> 0" by auto
  note pf = perron_frobenius_for_complexity_jnf(1,7)[OF A n0 nonneg sr1 decomp, simplified]
  from pf(1) pf(2)[OF 1 rt] show "\<exists> d. d \<noteq> 0 \<and> la ^ d = 1" by metis
qed

definition d where "d = (SOME d. \<forall> la. la \<in> snd ` set n_as \<longrightarrow> cmod la = 1 \<longrightarrow>
  d la \<noteq> 0 \<and> la ^ (d la) = 1)"

lemma d: assumes "(k,la) \<in> set n_as" "cmod la = 1"
  shows "la ^ (d la) = 1 \<and> d la \<noteq> 0"
proof -
  let ?P = "\<lambda> d. \<forall> la. la \<in> snd ` set n_as \<longrightarrow> cmod la = 1 \<longrightarrow>
    d la \<noteq> 0 \<and> la ^ (d la) = 1"
  from root_unity_cmod_1 have "\<forall> la. \<exists> d. la \<in> snd ` set n_as \<longrightarrow> cmod la = 1 \<longrightarrow>
    d \<noteq> 0 \<and> la ^ d = 1" by blast
  from choice[OF this] have "\<exists> d. ?P d" .
  from someI_ex[OF this] have "?P d" unfolding d_def .
  from this[rule_format, of la, OF _ assms(2)] assms(1) show ?thesis by force
qed

definition D where "D = prod_list (map (\<lambda> na. if cmod (snd na) = 1 then d (snd na) else 1) n_as)"

lemma D0: "D \<noteq> 0" unfolding D_def
  by (unfold prod_list_zero_iff, insert d, force)

definition f where "f off k = D * k + (m-1) + off"

lemma mono_f: "strict_mono (f off)" unfolding strict_mono_def f_def
  using D0 by auto

definition inv_op where "inv_op off k = inverse (c * real (f off k) ^ (m - 1))"

lemma limit_jordan_block: assumes kla: "(k, la) \<in> set n_as"
  and ij: "i < k" "j < k"
shows "(\<lambda>N. (jordan_block k la ^\<^sub>m (f off N)) $$ (i, j) * inv_op off N)
  \<longlonglongrightarrow> (if i = 0 \<and> j = k - 1 \<and> cmod la = 1 \<and> k = m then la^off else 0)"
proof -
  let ?c = "of_nat :: nat \<Rightarrow> complex"
  let ?r = "of_nat :: nat \<Rightarrow> real"
  let ?cr = complex_of_real
  from ij have k0: "k \<noteq> 0" by auto
  from jordan_nf_char_poly[OF jnf] have cA: "char_poly cA = (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)" .
  from degree_monic_char_poly[OF A] have "degree (char_poly A) = n" by auto
  have deg: "degree (char_poly cA) = n" using A by (simp add: degree_monic_char_poly)
  from this[unfolded cA] have "n = degree (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)" by auto
  also have "\<dots> =  sum_list (map degree (map (\<lambda>(n, a). [:- a, 1:] ^ n) n_as))"
    by (subst degree_prod_list_eq, auto)
  also have "\<dots> = sum_list (map fst n_as)"
    by (rule arg_cong[of _ _ sum_list], auto simp: degree_linear_power)
  finally have sum: "sum_list (map fst n_as) = n" by auto
  with split_list[OF kla] k0 have n0: "n \<noteq> 0" by auto
  obtain ks small where decomp: "decompose_prod_root_unity (char_poly A) = (ks, small)" by force
  note pf = perron_frobenius_for_complexity_jnf[OF A n0 nonneg sr1 decomp]
  define ji where "ji = j - i"
  have ji: "j - i = ji" unfolding ji_def by auto
  let ?f = "\<lambda> N. c * (?r N)^(m-1)"
  let ?jb = "\<lambda> N. (jordan_block k la ^\<^sub>m N) $$ (i,j)"
  let ?jbc = "\<lambda> N. (jordan_block k la ^\<^sub>m N) $$ (i,j) / ?f N"
  define e where "e = (if i = 0 \<and> j = k - 1 \<and> cmod la = 1 \<and> k = m then la^off else 0)"
  let ?e1 = "\<lambda> N :: nat. ?cr (poly (p (j - i)) (?r N)) * la ^ (N + i - j)"
  let ?e2 = "\<lambda> N. ?cr (poly (p ji) (?r N) / ?f N) * la ^ (N + i - j)"
  define e2 where "e2 = ?e2"
  let ?e3 = "\<lambda> N. poly (p ji) (?r N) / (c * ?r N ^ (m - 1)) * cmod la ^ (N + i - j)"
  define e3 where "e3 = ?e3"
  define e3' where "e3' = (\<lambda> N. (lead_coeff (p ji) * (?r N) ^ ji) / (c * ?r N ^ (m - 1)) * cmod la ^ (N + i - j))"
  {
    assume ij': "i \<le> j" and la0: "la \<noteq> 0"
    {
      fix N
      assume "N \<ge> k"
      with ij ij' have ji: "j - i \<le> N" and id: "N + i - j = N - ji" unfolding ji_def by auto
      have "?jb N = (?c (N choose (j - i)) * la ^ (N + i - j))"
        unfolding jordan_block_pow using ij ij' by auto
      also have "\<dots> = ?e1 N" by (subst p_binom_complex[OF ji], auto)
      finally have id: "?jb N = ?e1 N" .
      have "?jbc N = e2 N"
        unfolding id e2_def ji_def using c_gt_0 by (simp add: norm_mult norm_divide norm_power)
    } note jbc = this
    have cmod_e2_e3: "(\<lambda> n. cmod (e2 n)) \<sim>[at_top] e3"
    proof (intro asymp_equivI LIMSEQ_I exI[of _ ji] allI impI)
      fix n r
      assume n: "n \<ge> ji"
      have "cmod (e2 n) = \<bar>poly (p ji) (?r n) / (c * ?r n ^ (m - 1))\<bar> * cmod la ^ (n + i - j)"
        unfolding e2_def norm_mult norm_power norm_of_real by simp
      also have "\<bar>poly (p ji) (?r n) / (c * ?r n ^ (m - 1))\<bar> = poly (p ji) (?r n) / (c * real n ^ (m - 1))"
        by (intro abs_of_nonneg divide_nonneg_nonneg mult_nonneg_nonneg, insert c_gt_0, auto simp: p_binom[OF n, symmetric])
      finally have "cmod (e2 n) = e3 n" unfolding e3_def by auto
      thus "r > 0 \<Longrightarrow> norm ((if cmod (e2 n) = 0 \<and> e3 n = 0 then 1 else cmod (e2 n) / e3 n) - 1) < r" by simp
    qed
    have e3': "e3 \<sim>[at_top] e3'" unfolding e3_def e3'_def
      by (intro asymp_equiv_intros, insert poly_asymp_equiv[of "p ji"], unfold deg_p)
    {
      assume "e3' \<longlonglongrightarrow> 0"
      hence e3: "e3 \<longlonglongrightarrow> 0" using e3' by (meson tendsto_asymp_equiv_cong)
      have "e2 \<longlonglongrightarrow> 0"
        by (subst tendsto_norm_zero_iff[symmetric], subst tendsto_asymp_equiv_cong[OF cmod_e2_e3], rule e3)
    } note e2_via_e3 = this

    have "(e2 o f off) \<longlonglongrightarrow> e"
    proof (cases "cmod la = 1 \<and> k = m \<and> i = 0 \<and> j = k - 1")
      case False
      then consider (0) "la = 0" | (small) "la \<noteq> 0" "cmod la < 1" |
        (medium) "cmod la = 1" "k < m \<or> i \<noteq> 0 \<or> j \<noteq> k - 1"
        using max_block[OF kla] by linarith
      hence main: "e2 \<longlonglongrightarrow> e"
      proof cases
        case 0
        hence e0: "e = 0" unfolding e_def by auto
        show ?thesis unfolding e0 0 LIMSEQ_iff e2_def ji
        proof (intro exI[of _ "Suc j"] impI allI, goal_cases)
          case (1 r n) thus ?case by (cases "n + i - j", auto)
        qed
      next
        case small
        define d where "d = cmod la"
        from small have d: "0 < d" "d < 1" unfolding d_def by auto
        have e0: "e = 0" using small unfolding e_def by auto
        show ?thesis unfolding e0
          by (intro e2_via_e3, unfold e3'_def d_def[symmetric], insert d c0, real_asymp)
      next
        case medium
        with max_block[OF kla] have "k \<le> m" by auto
        with ij medium have ji: "ji < m - 1" unfolding ji_def by linarith
        have e0: "e = 0" using medium unfolding e_def by auto
        show ?thesis unfolding e0
          by (intro e2_via_e3, unfold e3'_def medium power_one mult_1_right, insert ji c0, real_asymp)
      qed
      show "(e2 o f off) \<longlonglongrightarrow> e"
        by (rule LIMSEQ_subseq_LIMSEQ[OF main mono_f])
    next
      case True
      hence large: "cmod la = 1" "k = m" "i = 0" "j = k - 1" by auto
      hence e: "e = la^off" and ji: "ji = m - 1" unfolding e_def ji_def by auto
      from large k0 have m0: "m \<ge> 1" by auto
      define m1 where "m1 = m - 1"
      have id: "(real (m - 1) - real ia) = ?r m - 1 - ?r ia" for ia using m0 unfolding m1_def by auto
      define q where "q = p m1 - monom c m1"
      hence pji: "p ji = q + monom c m1" unfolding q_def ji m1_def by simp
      let ?e4a = "\<lambda> x. (complex_of_real (poly q (real x) / (c * real x ^ m1))) * la ^ (x + i - j)"
      let ?e4b = "\<lambda> x. la ^ (x + i - j)"
      {
        fix x :: nat
        assume x: "x \<noteq> 0"
        have "e2 x = ?e4a x + ?e4b x"
          unfolding e2_def pji poly_add poly_monom m1_def[symmetric] using c0 x by (simp add: field_simps)
      } note e2_e4 = this
      have e2_e4: "\<forall>\<^sub>F x in sequentially. (e2 o f off) x = (?e4a o f off) x + (?e4b o f off) x"  unfolding o_def
        by (intro eventually_sequentiallyI[of "Suc 0"], rule e2_e4, insert D0, auto simp: f_def)
      have "(e2 o f off) \<longlonglongrightarrow> 0 + e"
        unfolding tendsto_cong[OF e2_e4]
      proof (rule tendsto_add, rule LIMSEQ_subseq_LIMSEQ[OF _ mono_f])
        show "?e4a \<longlonglongrightarrow> 0"
        proof (subst tendsto_norm_zero_iff[symmetric],
            unfold norm_mult norm_power large power_one mult_1_right norm_divide norm_of_real
            tendsto_rabs_zero_iff)
          have deg_q: "degree q \<le> m1" unfolding q_def using deg_p[of m1]
            by (intro degree_diff_le degree_monom_le, auto)
          have coeff_q_m1: "coeff q m1 = 0" unfolding q_def c_def m1_def[symmetric] using deg_p[of m1] by simp
          from deg_q coeff_q_m1 have deg: "degree q < m1 \<or> q = 0" by fastforce
          have eq: "(\<lambda>n. poly q (real n) / (c * real n ^ m1)) \<sim>[at_top]
                    (\<lambda>n. lead_coeff q * real n ^ degree q / (c * real n ^ m1))"
            by (intro asymp_equiv_intros poly_asymp_equiv)
          show "(\<lambda>n. poly q (?r n) / (c * ?r n ^ m1)) \<longlonglongrightarrow> 0"
            unfolding tendsto_asymp_equiv_cong[OF eq] using deg
            by (standard, insert c0, real_asymp, simp)
        qed
      next
        have id: "D * x + (m - 1) + off + i - j = D * x + off" for x
          unfolding ji[symmetric] ji_def using ij' by auto
        from d[OF kla large(1)] have 1: "la ^ d la = 1" by auto
        from split_list[OF kla] obtain as bs where n_as: "n_as = as @ (k,la) # bs" by auto
        obtain C where D: "D = d la * C" unfolding D_def unfolding n_as using large by auto
        show "(?e4b o f off) \<longlonglongrightarrow> e"
          unfolding e f_def o_def id
          unfolding power_add power_mult D 1 by auto
      qed
      thus ?thesis by simp
    qed
    also have "((e2 o f off) \<longlonglongrightarrow> e) = ((?jbc o f off)  \<longlonglongrightarrow> e)"
    proof (rule tendsto_cong, unfold eventually_at_top_linorder, rule exI[of _ k],
        intro allI impI, goal_cases)
      case (1 n)
      from mono_f[of off] 1 have "f off n \<ge> k" using le_trans seq_suble by blast
      from jbc[OF this] show ?case by (simp add: o_def)
    qed
    finally have "(?jbc o f off) \<longlonglongrightarrow> e" .
  } note part1 = this
  {
    assume "i > j \<or> la = 0"
    hence e: "e = 0" and jbn: "N \<ge> k \<Longrightarrow> ?jbc N = 0" for N
      unfolding jordan_block_pow e_def using ij by auto
    have "?jbc \<longlonglongrightarrow> e" unfolding e LIMSEQ_iff by (intro exI[of _ k] allI impI, subst jbn, auto)
    from LIMSEQ_subseq_LIMSEQ[OF this mono_f]
    have "(?jbc o f off) \<longlonglongrightarrow> e" .
  } note part2 = this
  from part1 part2 have "(?jbc o f off) \<longlonglongrightarrow> e" by linarith
  thus ?thesis unfolding e_def o_def inv_op_def by (simp add: field_simps)
qed

definition lambda where "lambda i = snd (n_as ! fst (j_to_jb_index n_as i))"

lemma cmod_lambda: "i \<in> C \<Longrightarrow> cmod (lambda i) = 1"
  unfolding C_def lambda_def by auto

lemma R_lambda: assumes i: "i \<in> C"
  shows "(m, lambda i) \<in> set n_as"
proof -
  from i[unfolded C_def]
  obtain bi li la where i: "i < n" and jb: "j_to_jb_index n_as i = (bi, li)"
    and nth: "n_as ! bi = (m, la)" and "cmod la = 1 \<and> li = m - 1" by auto
  hence lam: "lambda i = la" unfolding lambda_def by auto
  from j_to_jb_index[of _ n_as, unfolded sumlist_nf, OF i i jb jb nth] lam
  show ?thesis by auto
qed

lemma limit_jordan_matrix: assumes ij: "i < n" "j < n"
shows "(\<lambda>N. (J ^\<^sub>m (f off N)) $$ (i, j) * inv_op off N)
  \<longlonglongrightarrow> (if j \<in> C \<and> i = j - (m - 1) then (lambda j)^off else 0)"
proof -
  obtain bi li where bi: "j_to_jb_index n_as i = (bi, li)" by force
  obtain bj lj where bj: "j_to_jb_index n_as j = (bj, lj)" by force
  define la where "la = snd (n_as ! fst (j_to_jb_index n_as j))"
  obtain nn where nbj: "n_as ! bj = (nn,la)" unfolding la_def bj fst_conv by (metis prod.collapse)
  from j_to_jb_index[OF ij[folded sumlist_nf] bi bj nbj]
  have eq: "bi = bj \<Longrightarrow> li < nn \<and> lj < nn \<and> bj < length n_as \<and> (nn, la) \<in> set n_as" and
    index: "(J ^\<^sub>m r) $$ (i, j) =
    (if bi = bj then (jordan_block nn la ^\<^sub>m r) $$ (li, lj) else 0)" for r
    by auto
  note index_rev = j_to_jb_index_rev[OF bj, unfolded sumlist_nf, OF ij(2) le_refl]
  show ?thesis
  proof (cases "bi = bj")
    case False
    hence id: "(bi = bj) = False" by auto
    {
      assume "j \<in> C" "i = j - (m - 1)"
      from this[unfolded C_def] bj nbj have "i = j - lj" by auto
      from index_rev[folded this] bi False have False by auto
    }
    thus ?thesis unfolding index id if_False by auto
  next
    case True
    hence id: "(bi = bj) = True" by auto
    from eq[OF True] have eq: "li < nn" "lj < nn" "(nn,la) \<in> set n_as" "bj < length n_as" by auto
    have "(\<lambda>N. (J ^\<^sub>m (f off N)) $$ (i, j) * inv_op off N)
      \<longlonglongrightarrow> (if li = 0 \<and> lj = nn - 1 \<and> cmod la = 1 \<and> nn = m then la^off else 0)"
      unfolding index id if_True using limit_jordan_block[OF eq(3,1,2)] .
    also have "(li = 0 \<and> lj = nn - 1 \<and> cmod la = 1 \<and> nn = m) = (j \<in> C \<and> i = j - (m - 1))" (is "?l = ?r")
    proof
      assume ?r
      hence "j \<in> C" ..
      from this[unfolded C_def] bj nbj
      have *: "nn = m" "cmod la = 1" "lj = nn - 1" by auto
      from \<open>?r\<close> * have "i = j - lj" by auto
      with * have "li = 0" using index_rev bi by auto
      with * show ?l by auto
    next
      assume ?l
      hence jI: "j \<in> C" using bj nbj ij by (auto simp: C_def)
      from \<open>?l\<close> have "li = 0" by auto
      with index_rev[of i] bi ij(1) \<open>?l\<close> True
      have "i = j - (m - 1)" by auto
      with jI show ?r by auto
    qed
    finally show ?thesis unfolding la_def lambda_def .
  qed
qed

declare sumlist_nf[simp]

lemma A_power_P: "cA ^\<^sub>m k * P = P * J ^\<^sub>m k"
proof (induct k)
  case 0
  show ?case using A JNF by simp
next
  case (Suc k)
  have "cA ^\<^sub>m Suc k * P = cA ^\<^sub>m k * cA * P" by simp
  also have "\<dots> = cA ^\<^sub>m k * (P * J * iP) * P" using JNF by simp
  also have "\<dots> = (cA ^\<^sub>m k * P) * (J * (iP * P))"
    using A JNF(1-3) by (simp add: assoc_mult_mat[of _ n n _ n _ n])
  also have "J * (iP * P) = J" unfolding JNF using JNF by auto
  finally show ?case unfolding Suc
    using A JNF(1-3) by (simp add: assoc_mult_mat[of _ n n _ n _ n])
qed

lemma inv_op_nonneg: "inv_op off k \<ge> 0" unfolding inv_op_def using c_gt_0 by auto

lemma P_nonzero_entry: assumes j: "j < n"
  shows "\<exists> i < n. P $$ (i,j) \<noteq> 0"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence 0: "\<And> i. i < n \<Longrightarrow> P $$ (i,j) = 0" by auto
  have "1 = (iP * P) $$ (j,j)" using j unfolding JNF by auto
  also have "\<dots> = (\<Sum>i = 0..<n. iP $$ (j, i) * P $$ (i, j))"
    using j JNF(1-2) by (auto simp: scalar_prod_def)
  also have "\<dots> = 0" by (rule sum.neutral, insert 0, auto)
  finally show False by auto
qed

definition j where "j = (SOME j. j \<in> C)"

lemma j: "j \<in> C" unfolding j_def using C_nonempty some_in_eq by blast

lemma j_n: "j < n" using j unfolding C_def by auto

definition "i = (SOME i. i < n \<and> P $$ (i, j - (m - 1)) \<noteq> 0)"

lemma i: "i < n" and P_ij0: "P $$ (i, j - (m - 1)) \<noteq> 0"
proof -
  from j_n have lt: "j - (m - 1) < n" by auto
  show "i < n" "P $$ (i, j - (m - 1)) \<noteq> 0"
    unfolding i_def using someI_ex[OF P_nonzero_entry[OF lt]] by auto
qed

definition "w = P *\<^sub>v unit_vec n j"

definition "v = map_vec cmod w"

lemma v: "v \<in> carrier_vec n" unfolding v_def using w by auto

definition u where "u = iP *\<^sub>v map_vec of_real v"

lemma u: "u \<in> carrier_vec n" unfolding u_def using JNF(2) v by auto

definition a where "a j = P $$ (i, j - (m - 1)) * u $v j" for j

lemma main_step: "0 < Re (\<Sum>j\<in>C. a j * lambda j ^ l)"
proof -
  let ?c = "complex_of_real"
  let ?cv = "map_vec ?c"
  let ?cm = "map_mat ?c"
  let ?v = "?cv v"
  define cc where
    "cc = (\<lambda> jj. ((\<Sum>k = 0..<n. (if k = jj - (m - 1) then P $$ (i, k) else 0)) * u $v jj))"
  {
    fix off
    define G where "G = (\<lambda> k. (A ^\<^sub>m f off k *\<^sub>v v) $v i * inv_op off k)"
    define F where "F = (\<Sum>j\<in>C. a j * lambda j ^ off)"
    {
      fix kk
      define k where "k = f off kk"
      have "((A ^\<^sub>m k) *\<^sub>v v) $ i * inv_op off kk = Re (?c (((A ^\<^sub>m k) *\<^sub>v v) $ i * inv_op off kk))" by simp
      also have "?c (((A ^\<^sub>m k) *\<^sub>v v) $ i * inv_op off kk) = ?cv ((A ^\<^sub>m k) *\<^sub>v v) $ i * ?c (inv_op off kk)"
        using i A by simp
      also have "?cv ((A ^\<^sub>m k) *\<^sub>v v) = (?cm (A ^\<^sub>m k) *\<^sub>v ?v)" using A
        by (subst of_real_hom.mult_mat_vec_hom[OF _ v], auto)
      also have "\<dots> = (cA ^\<^sub>m k *\<^sub>v ?v)"
        by (simp add: of_real_hom.mat_hom_pow[OF A])
      also have "\<dots> = (cA ^\<^sub>m k *\<^sub>v ((P * iP) *\<^sub>v ?v))" unfolding JNF using v by auto
      also have "\<dots> = (cA ^\<^sub>m k *\<^sub>v (P *\<^sub>v u))" unfolding u_def
        by (subst assoc_mult_mat_vec, insert JNF v, auto)
      also have "\<dots> = (P * J ^\<^sub>m k *\<^sub>v u)" unfolding A_power_P[symmetric]
        by (subst assoc_mult_mat_vec, insert u JNF(1) A, auto)
      also have "\<dots> = (P *\<^sub>v (J ^\<^sub>m k *\<^sub>v u))"
        by (rule assoc_mult_mat_vec, insert u JNF(1) A, auto)
      finally have "(A ^\<^sub>m k *\<^sub>v v) $v i * inv_op off kk = Re ((P *\<^sub>v (J ^\<^sub>m k *\<^sub>v u)) $ i * inv_op off kk)" by simp
      also have "\<dots> = Re (\<Sum>jj = 0..<n.
           P $$ (i, jj) * (\<Sum>ia = 0..< n. (J ^\<^sub>m k) $$ (jj, ia) * u $v ia * inv_op off kk))"
        by (subst index_mult_mat_vec, insert JNF(1) i u, auto simp: scalar_prod_def sum_distrib_right[symmetric]
           mult.assoc[symmetric])
      finally have "(A ^\<^sub>m k *\<^sub>v v) $v i * inv_op off kk =
        Re (\<Sum>jj = 0..<n. P $$ (i, jj) * (\<Sum>ia = 0..<n. (J ^\<^sub>m k) $$ (jj, ia) * inv_op off kk * u $v ia))"
        unfolding k_def
        by (simp only: ac_simps)
    } note A_to_u = this
    have "G \<longlonglongrightarrow>
       Re (\<Sum>jj = 0..<n. P $$ (i, jj) *
           (\<Sum>ia = 0..<n. (if ia \<in> C \<and> jj = ia - (m - 1) then (lambda ia)^off else 0) * u $v ia))"
      unfolding A_to_u G_def
      by (intro tendsto_intros limit_jordan_matrix, auto)
    also have "(\<Sum>jj = 0..<n. P $$ (i, jj) *
           (\<Sum>ia = 0..<n. (if ia \<in> C \<and> jj = ia - (m - 1) then (lambda ia)^off else 0) * u $v ia))
      = (\<Sum>jj = 0..<n. (\<Sum>ia \<in> C. (if ia \<in> C \<and> jj = ia - (m - 1) then P $$ (i, jj) else 0) * ((lambda ia)^off * u $v ia)))"
      by (rule sum.cong[OF refl], unfold sum_distrib_left, subst (2) sum.mono_neutral_left[of "{0..<n}"],
        insert C_n, auto intro!: sum.cong)
    also have "\<dots> = (\<Sum>ia \<in> C. (\<Sum>jj = 0..<n. (if jj = ia - (m - 1) then P $$ (i, jj) else 0)) * ((lambda ia)^off * u $v ia))"
      unfolding sum.swap[of _ C] sum_distrib_right
      by (rule sum.cong[OF refl], auto)
    also have "\<dots> = (\<Sum>ia \<in> C. cc ia * (lambda ia)^off)" unfolding cc_def
      by (rule sum.cong[OF refl], simp)
    also have "\<dots> = F" unfolding cc_def a_def F_def
      by (rule sum.cong[OF refl], insert C_n, auto)
    finally have tend3: "G \<longlonglongrightarrow> Re F" .
    (* so far we did not use the definition of i or v, except that v is a real vector.
       Hence, the result holds independently of i and v (if one would drop the Re) *)

    from j j_n have jR: "j \<in> C" and j: "j < n" by auto
    let ?exp = "\<lambda> k. sum (\<lambda> ii. P $$ (i, ii) * (J ^\<^sub>m k) $$ (ii,j)) {..<n}"
    define M where "M = (\<lambda> k. cmod (?exp (f off k) * inv_op off k))"
    {
      fix kk
      define k where "k = f off kk"
      define cAk where "cAk = cA ^\<^sub>m k"
      have cAk: "cAk \<in> carrier_mat n n" unfolding cAk_def using A by auto
      have "((A ^\<^sub>m k) *\<^sub>v v) $ i = ((map_mat cmod cAk) *\<^sub>v map_vec cmod w) $ i"
        unfolding v_def[symmetric] cAk_def
        by (rule arg_cong[of _ _ "\<lambda> x. (x *\<^sub>v v) $ i"],
          unfold of_real_hom.mat_hom_pow[OF A, symmetric],
        insert nonneg_mat_power[OF A nonneg, of k], insert i j,
        auto simp: nonneg_mat_def elements_mat_def)
      also have "\<dots> \<ge> cmod ((cAk *\<^sub>v w) $ i)"
        by (subst (1 2) index_mult_mat_vec, insert i cAk w, auto simp: scalar_prod_def
        intro!: sum_norm_le norm_mult_ineq)
      also have "cAk *\<^sub>v w = (cAk * P) *\<^sub>v unit_vec n j"
        unfolding w_def using JNF cAk by simp
      also have "\<dots> = P *\<^sub>v (J ^\<^sub>m k *\<^sub>v unit_vec n j)" unfolding cAk_def A_power_P
        using JNF by (subst assoc_mult_mat_vec[of _ n n _ n], auto)
      also have "J ^\<^sub>m k *\<^sub>v unit_vec n j = col (J ^\<^sub>m k) j"
        by (rule eq_vecI, insert j, auto)
      also have "(P *\<^sub>v (col (J ^\<^sub>m k) j)) $ i = Matrix.row P i \<bullet> col (J ^\<^sub>m k) j"
        by (subst index_mult_mat_vec, insert i JNF, auto)
      also have "\<dots> = sum (\<lambda> ii. P $$ (i, ii) * (J ^\<^sub>m k) $$ (ii,j)) {..<n}"
        unfolding scalar_prod_def by (rule sum.cong, insert i j JNF(1), auto)
      finally have "(A ^\<^sub>m k *\<^sub>v v) $v i \<ge> cmod (?exp k)" .
      from mult_right_mono[OF this inv_op_nonneg]
      have "(A ^\<^sub>m k *\<^sub>v v) $v i * inv_op off kk \<ge> cmod (?exp k * inv_op off kk)" unfolding norm_mult
        using inv_op_nonneg by auto
    }
    hence ge: "(A ^\<^sub>m f off k *\<^sub>v v) $v i * inv_op off k \<ge> M k" for k unfolding M_def by auto
    from j have mem: "j - (m - 1) \<in> {..<n}" by auto
    have "(\<lambda> k. ?exp (f off k) * inv_op off k) \<longlonglongrightarrow>
      (\<Sum>ii<n. P $$ (i, ii) * (if j \<in> C \<and> ii = j - (m - 1) then lambda j ^ off else 0))"
      (is "_ \<longlonglongrightarrow> ?sum")
      unfolding sum_distrib_right mult.assoc
      by (rule tendsto_sum, rule tendsto_mult, force, rule limit_jordan_matrix[OF _ j], auto)
    also have "?sum = P $$ (i, j - (m - 1)) * lambda j ^ off"
      by (subst sum.remove[OF _ mem], force, subst sum.neutral, insert jR, auto)
    finally have tend1: "(\<lambda> k. ?exp (f off k) * inv_op off k) \<longlonglongrightarrow> P $$ (i, j - (m - 1)) * lambda j ^ off" .
    have tend2: "M \<longlonglongrightarrow> cmod (P $$ (i, j - (m - 1)) * lambda j ^ off)" unfolding M_def
      by (rule tendsto_norm, rule tend1)
    define B where "B = cmod (P $$ (i, j - (m - 1))) / 2"
    have B: "0 < B" unfolding B_def using P_ij0 by auto
    {
      from P_ij0 have 0: "P $$ (i, j - (m - 1)) \<noteq> 0" by auto
      define E where "E = cmod (P $$ (i, j - (m - 1)) * lambda j ^ off)"
      from cmod_lambda[OF jR] 0 have E: "E / 2 > 0" unfolding E_def by auto
      from tend2[folded E_def] have tend2: "M \<longlonglongrightarrow> E" .
      from ge have ge: "G k \<ge> M k" for k unfolding G_def .
      from tend2[unfolded LIMSEQ_iff, rule_format, OF E]
      obtain k' where diff: "\<And> k. k \<ge> k' \<Longrightarrow> norm (M k - E) < E / 2" by auto
      {
        fix k
        assume "k \<ge> k'"
        from diff[OF this] have norm: "norm (M k - E) < E / 2" .
        have "M k \<ge> 0" unfolding M_def by auto
        with E norm have "M k \<ge> E / 2"
          by (smt real_norm_def field_sum_of_halves)
        with ge[of k] E have "G k \<ge> E / 2" by auto
        also have "E / 2 = B" unfolding E_def B_def j norm_mult norm_power
          cmod_lambda[OF jR] by auto
        finally have "G k \<ge> B" .
      }
      hence "\<exists> k'. \<forall> k. k \<ge> k' \<longrightarrow> G k \<ge> B" by auto
    }
    hence Bound: "\<exists>k'. \<forall>k\<ge>k'. B \<le> G k" by auto
    from tend3[unfolded LIMSEQ_iff, rule_format, of "B / 2"] B
    obtain kk where kk: "\<And> k. k \<ge> kk \<Longrightarrow> norm (G k - Re F) < B / 2" by auto
    from Bound obtain kk' where kk': "\<And> k. k \<ge> kk' \<Longrightarrow> B \<le> G k" by auto
    define k where "k = max kk kk'"
    with kk kk' have 1: "norm (G k - Re F) < B / 2" "B \<le> G k" by auto
    with B have "Re F > 0" by (smt real_norm_def field_sum_of_halves)
  }
  thus ?thesis by blast
qed

lemma main_theorem: "(m, 1) \<in> set n_as"
proof -
  from main_step have pos: "0 < Re (\<Sum>i\<in>C. a i * lambda i ^ l)" for l by auto
  have "1 \<in> lambda ` C"
  proof (rule sum_root_unity_power_pos_implies_1[of a lambda C, OF pos])
    fix i
    assume "i \<in> C"
    from d[OF R_lambda[OF this] cmod_lambda[OF this]]
    show "\<exists>d. d \<noteq> 0 \<and> lambda i ^ d = 1" by auto
  qed
  then obtain i where i: "i \<in> C" and "lambda i = 1" by auto
  with R_lambda[OF i] show ?thesis by auto
qed
end

lemma nonneg_sr_1_largest_jb:
  assumes nonneg: "nonneg_mat A"
  and jnf: "jordan_nf (map_mat complex_of_real A) n_as"
  and mem: "(m, lam) \<in> set n_as"
  and lam1: "cmod lam = 1"
  and sr1: "\<And>x. poly (char_poly A) x = 0 \<Longrightarrow> x \<le> 1"
  shows "\<exists> M. M \<ge> m \<and> (M,1) \<in> set n_as"
proof -
  note jnf' = jnf[unfolded jordan_nf_def]
  from jnf' similar_matD[OF jnf'[THEN conjunct2]] obtain n
    where A: "A \<in> carrier_mat n n" and n_as0: "0 \<notin> fst ` set n_as" by auto
  let ?M = "{ m. \<exists> lam. (m,lam) \<in> set n_as \<and> cmod lam = 1}"
  have m: "m \<in> ?M" using mem lam1 by auto
  have fin: "finite ?M"
    by (rule finite_subset[OF _ finite_set[of "map fst n_as"]], force)
  define M where "M = Max ?M"
  have "M \<in> ?M" using fin m unfolding M_def using Max_in by blast
  then obtain lambda where M: "(M,lambda) \<in> set n_as" "cmod lambda = 1" by auto
  from m fin have mM: "m \<le> M" unfolding M_def by simp
  interpret spectral_radius_1_jnf_max A n M lambda
  proof (unfold_locales, rule A, rule nonneg, rule jnf, rule M, rule M, rule sr1)
    fix k la
    assume kla: "(k, la) \<in> set n_as"
    with fin have 1: "cmod la = 1 \<longrightarrow> k \<le> M" unfolding M_def using Max_ge by blast
    obtain ks f where decomp: "decompose_prod_root_unity (char_poly A) = (ks, f)" by force
    from n_as0 kla have k0: "k \<noteq> 0" by force
    let ?cA = "map_mat complex_of_real A"
    from split_list[OF kla] obtain as bs where nas: "n_as = as @ (k,la) # bs" by auto
    have rt: "poly (char_poly ?cA) la = 0" using k0
      unfolding jordan_nf_char_poly[OF jnf] nas poly_prod_list prod_list_zero_iff by auto
    have sumlist_nf: "sum_list (map fst n_as) = n"
    proof -
      have "sum_list (map fst n_as) = dim_row (jordan_matrix n_as)" by simp
      also have "\<dots> = dim_row ?cA" using similar_matD[OF jnf'[THEN conjunct2]] by auto
      finally show ?thesis using A by auto
    qed
    from this[unfolded nas] k0 have n0: "n \<noteq> 0" by auto
    from perron_frobenius_for_complexity_jnf(4)[OF A n0 nonneg sr1 decomp rt]
    have "cmod la \<le> 1" .
    with 1 show "cmod la \<le> 1 \<and> (cmod la = 1 \<longrightarrow> k \<le> M)" by auto
  qed
  from main_theorem
  show ?thesis using mM by auto
qed
hide_const(open) spectral_radius

lemma (in ring_hom) hom_smult_mat: "mat\<^sub>h (a \<cdot>\<^sub>m A) = hom a \<cdot>\<^sub>m mat\<^sub>h A"
  by (rule eq_matI, auto simp: hom_mult)

lemma root_char_poly_smult: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  and k: "k \<noteq> 0"
shows "(poly (char_poly (k \<cdot>\<^sub>m A)) x = 0) = (poly (char_poly A) (x / k) = 0)"
  using order_char_poly_smult[OF A k, of x]
  by (metis A degree_0 degree_monic_char_poly monic_degree_0 order_root smult_carrier_mat)

theorem real_nonneg_mat_spectral_radius_largest_jordan_block:
  assumes "real_nonneg_mat A"
  and "jordan_nf A n_as"
  and "(m, lam) \<in> set n_as"
  and "cmod lam = spectral_radius A"
shows "\<exists> M \<ge> m. (M, of_real (spectral_radius A)) \<in> set n_as"
proof -
  from similar_matD[OF assms(2)[unfolded jordan_nf_def, THEN conjunct2]] obtain n where
    A: "A \<in> carrier_mat n n" by auto
  let ?c = complex_of_real
  define B where "B = map_mat Re A"
  have B: "B \<in> carrier_mat n n" unfolding B_def using A by auto
  have AB: "A = map_mat ?c B" unfolding B_def using assms(1)
    by (auto simp: real_nonneg_mat_def elements_mat_def)
  have nonneg: "nonneg_mat B" using assms(1) unfolding AB
    by (auto simp: real_nonneg_mat_def elements_mat_def nonneg_mat_def)
  let ?sr = "spectral_radius A"
  show ?thesis
  proof (cases "?sr = 0")
    case False
    define isr where "isr = inverse ?sr"
    let ?nas = "map (\<lambda>(n, a). (n, ?c isr * a)) n_as"
    from False have isr0: "isr \<noteq> 0" unfolding isr_def by auto
    hence cisr0: "?c isr \<noteq> 0" by auto
    from False assms(4) have isr_pos: "isr > 0" unfolding isr_def
      by (smt norm_ge_zero positive_imp_inverse_positive)
    define C where "C = isr \<cdot>\<^sub>m B"
    have C: "C \<in> carrier_mat n n" using B unfolding C_def by auto
    have BC: "B = ?sr \<cdot>\<^sub>m C" using isr0 unfolding C_def isr_def by auto
    have nonneg: "nonneg_mat C" unfolding C_def using isr_pos nonneg
      unfolding nonneg_mat_def elements_mat_def by auto
    from jordan_nf_smult[OF assms(2)[unfolded AB] cisr0]
    have jnf: "jordan_nf (map_mat ?c C) ?nas" unfolding C_def by (auto simp: of_real_hom.hom_smult_mat)
    from assms(3) have mem: "(m, ?c isr * lam) \<in> set ?nas" by auto
    have 1: "cmod (?c isr * lam) = 1" using False isr_pos unfolding isr_def norm_mult assms(4)
      by (smt mult.commute norm_of_real right_inverse)
    {
      fix x
      have B': "map_mat ?c B \<in> carrier_mat n n" using B by auto
      assume "poly (char_poly C) x = 0"
      hence "poly (char_poly (map_mat ?c C)) (?c x) = 0" unfolding of_real_hom.char_poly_hom[OF C] by auto
      hence "poly (char_poly A) (?c x / ?c isr) = 0" unfolding C_def of_real_hom.hom_smult_mat AB
        unfolding root_char_poly_smult[OF B' cisr0] .
      hence "eigenvalue A (?c x / ?c isr)" unfolding eigenvalue_root_char_poly[OF A] .
      hence mem: "cmod (?c x / ?c isr) \<in> cmod ` spectrum A" unfolding spectrum_def by auto
      from Max_ge[OF finite_imageI this]
      have "cmod (?c x / ?c isr) \<le> ?sr" unfolding Spectral_Radius.spectral_radius_def
        using A card_finite_spectrum(1) by blast
      hence "cmod (?c x) \<le> 1" using isr0 isr_pos unfolding isr_def
        by (auto simp: field_simps norm_divide norm_mult)
      hence "x \<le> 1" by auto
    } note sr = this
    from nonneg_sr_1_largest_jb[OF nonneg jnf mem 1 sr] obtain M where
      M: "M \<ge> m" "(M,1) \<in> set ?nas" by blast
    from M(2) obtain a where mem: "(M,a) \<in> set n_as" and "1 = ?c isr * a" by auto
    from this(2) have a: "a = ?c ?sr" using isr0 unfolding isr_def by (auto simp: field_simps)
    show ?thesis
      by (intro exI[of _ M], insert mem a M(1), auto)
  next
    case True
    from jordan_nf_root_char_poly[OF assms(2,3)]
    have "eigenvalue A lam" unfolding eigenvalue_root_char_poly[OF A] .
    hence "cmod lam \<in> cmod ` spectrum A" unfolding spectrum_def by auto
    from Max_ge[OF finite_imageI this]
    have "cmod lam \<le> ?sr" unfolding Spectral_Radius.spectral_radius_def
      using A card_finite_spectrum(1) by blast
    from this[unfolded True] have lam0: "lam = 0" by auto
    show ?thesis unfolding True using assms(3)[unfolded lam0] by auto
  qed
qed

end


section \<open>Snippet to Define Custom Combinators\<close>
theory Sepref_Snip_Combinator
imports "../../IICF/IICF"
begin

  subsection \<open>Definition of the Combinator\<close>

  text \<open>
    Currently, when defining new combinators, you are largely on your own.
    If you can show your combinator equivalent to some other, already existing,
    combinator, you should apply this equivalence in the monadify phase.

    In this example, we show the development of a map combinator from scratch.
    \<close>

  text \<open>We set ourselves in to a context where we fix the abstract and concrete
    arguments of the monadic map combinator, as well as the refinement assertions,
    and a frame, that represents the remaining heap content, and may be read by the map-function. \<close>
  context
    fixes f :: "'a \<Rightarrow> 'b nres"
    fixes l :: "'a list"

    fixes fi :: "'ai \<Rightarrow> 'bi Heap"
    fixes li :: "'ai list"

    fixes A A' :: "'a \<Rightarrow> 'ai \<Rightarrow> assn" \<comment> \<open>Refinement for list elements before and after map-function.
      Different, as map function may invalidate list elements!\<close>
    fixes B :: "'b \<Rightarrow> 'bi \<Rightarrow> assn"

    fixes F :: assn \<comment> \<open>Symbolic frame, representing all heap content the map-function body may access\<close>

    notes [[sepref_register_adhoc f l]] \<comment> \<open>Register for operation id\<close>

    assumes f_rl: "hn_refine (hn_ctxt A x xi * F) (fi xi) (hn_ctxt A' x xi * F) B (f$x)"
      \<comment> \<open>Refinement for \<open>f\<close>\<close>

  begin

    text \<open>We implement our combinator using the monadic refinement framework.\<close>
    definition "mmap \<equiv> RECT (\<lambda>mmap.
      \<lambda>[] \<Rightarrow> RETURN []
    | x#xs \<Rightarrow> do { x \<leftarrow> f x; xs \<leftarrow> mmap xs; RETURN (x#xs) }) l"

    subsection \<open>Synthesis of Implementation\<close>

    text \<open>In order to propagate the frame \<open>F\<close> during synthesis, we use a trick: We wrap the
      frame into a dummy refinement assertion. This way, sepref recognizes the frame just as
      another context element, and does correct propagation.\<close>
    definition "F_assn (x::unit) (y::unit) \<equiv> F"
    lemma F_unf: "hn_ctxt F_assn x y = F"
      by (auto simp: F_assn_def hn_ctxt_def)

    text \<open>We build a combinator rule to refine \<open>f\<close>. We need a combinator rule here,
      because \<open>f\<close> does not only depend on its formal arguments, but also on the frame
      (represented as dummy argument). \<close>
    lemma f_rl': "hn_refine (hn_ctxt A x xi * hn_ctxt (F_assn) dx dxi) (fi xi) (hn_ctxt A' x xi * hn_ctxt (F_assn) dx dxi) B (f$x)"
      unfolding F_unf by (rule f_rl)

    text \<open>Then we use the Sepref tool to synthesize an implementation of \<open>mmap\<close>.\<close>
    schematic_goal mmap_impl:
      notes [sepref_comb_rules] = hn_refine_frame[OF f_rl']
      shows "hn_refine (hn_ctxt (list_assn A) l li * hn_ctxt (F_assn) dx dxi) (?c::?'c Heap) ?\<Gamma>' ?R mmap"
      unfolding mmap_def "HOL_list.fold_custom_empty"
      apply sepref_dbg_keep
      done

    text \<open>We unfold the wrapped frame\<close>
    lemmas mmap_impl' = mmap_impl[unfolded F_unf]

  end

  subsection \<open>Setup for Sepref\<close>
  text \<open>Outside the context, we extract the synthesized implementation as a new constant, and set up
    code theorems for the fixed-point combinators.\<close>
  concrete_definition mmap_impl uses mmap_impl'
  prepare_code_thms mmap_impl_def

  text \<open>Moreover, we have to manually declare arity and monadify theorems.
    The arity theorem ensures that we always have a constant number of operators, and
    the monadify theorem determines an execution order: The list-argument is evaluated first.
    \<close>
  lemma mmap_arity[sepref_monadify_arity]: "mmap \<equiv> \<lambda>\<^sub>2f l. SP mmap$(\<lambda>\<^sub>2x. f$x)$l" by simp
  lemma mmap_mcomb[sepref_monadify_comb]: "mmap$f$x \<equiv> (\<bind>)$(EVAL$x)$(\<lambda>\<^sub>2x. SP mmap$f$x)" by simp

  text \<open>We can massage the refinement theorem @{thm mmap_impl.refine} a bit, to get a valid
    combinator rule\<close>
  print_statement hn_refine_cons_pre[OF _ mmap_impl.refine, sepref_prep_comb_rule, no_vars]

  lemma mmap_comb_rl[sepref_comb_rules]:
    assumes "P \<Longrightarrow>\<^sub>t hn_ctxt (list_assn A) l li * F"
        \<comment> \<open>Initial frame\<close>
      and "\<And>x xi. hn_refine (hn_ctxt A x xi * F) (fi xi) (Q x xi) B (f x)"
        \<comment> \<open>Refinement of map-function\<close>
      and "\<And>x xi. Q x xi \<Longrightarrow>\<^sub>t hn_ctxt A' x xi * F"
        \<comment> \<open>Recover refinement for list-element and original frame from what map-function produced\<close>
    shows "hn_refine P (mmap_impl fi li) (hn_ctxt (list_assn A') l li * F) (list_assn B) (mmap$(\<lambda>\<^sub>2x. f x)$l)"
    unfolding APP_def PROTECT2_def
    using hn_refine_cons_pre[OF _ mmap_impl.refine, sepref_prep_comb_rule, of P A l li F fi Q B f A']
    using assms
    by simp

  subsection \<open>Example\<close>

  text \<open>Finally, we can test our combinator. Note how the
    map-function accesses the array on the heap, which is not among its arguments.
    This is only possible as we passed around a frame. \<close>

  sepref_thm test_mmap
    is "\<lambda>l. do { let a = op_array_of_list [True,True,False]; mmap (\<lambda>x. do { mop_list_get a (x mod 3) }) l }"
    :: "(list_assn nat_assn)\<^sup>k \<rightarrow>\<^sub>a list_assn bool_assn"
    unfolding HOL_list.fold_custom_empty
    by sepref

  subsection \<open>Limitations\<close>
  text \<open>
    Currently, the major limitation is that combinator rules are fixed to specific data types.
    In our example, we did an implementation for HOL lists. We cannot come up with an alternative implementation,
    for, e.g., array-lists, but have to use a different abstract combinator.

    One workaround is to use some generic operations, as is done for foreach-loops, which require
    a generic to-list operation. However, in this case, we produce unwanted intermediate lists, and
    would have to add complicated a-posteriori deforestation optimizations.
    \<close>

end


(*  Title:      ZF/IMP/Equiv.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section \<open>Equivalence\<close>

theory Equiv imports Denotation Com begin

lemma aexp_iff [rule_format]:
  "\<lbrakk>a \<in> aexp; sigma: loc -> nat\<rbrakk>
    \<Longrightarrow> \<forall>n. \<langle>a,sigma\<rangle> -a-> n \<longleftrightarrow> A(a,sigma) = n"
  apply (erule aexp.induct)
     apply (force intro!: evala.intros)+
  done

declare aexp_iff [THEN iffD1, simp]
        aexp_iff [THEN iffD2, intro!]

inductive_cases [elim!]:
  "\<langle>true,sigma\<rangle> -b-> x"
  "\<langle>false,sigma\<rangle> -b-> x"
  "<ROp(f,a0,a1),sigma> -b-> x"
  "<noti(b),sigma> -b-> x"
  "<b0 andi b1,sigma> -b-> x"
  "<b0 ori b1,sigma> -b-> x"

lemma bexp_iff [rule_format]:
  "\<lbrakk>b \<in> bexp; sigma: loc -> nat\<rbrakk>
    \<Longrightarrow> \<forall>w. \<langle>b,sigma\<rangle> -b-> w \<longleftrightarrow> B(b,sigma) = w"
  apply (erule bexp.induct)
  apply (auto intro!: evalb.intros)
  done

declare bexp_iff [THEN iffD1, simp]
        bexp_iff [THEN iffD2, intro!]

lemma com1: "\<langle>c,sigma\<rangle> -c-> sigma' \<Longrightarrow> <sigma,sigma'> \<in> C(c)"
  apply (erule evalc.induct)
        apply (simp_all (no_asm_simp))
     txt \<open>\<open>assign\<close>\<close>
     apply (simp add: update_type)
    txt \<open>\<open>comp\<close>\<close>
    apply fast
   txt \<open>\<open>while\<close>\<close>
   apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
   apply (simp add: Gamma_def)
  txt \<open>recursive case of \<open>while\<close>\<close>
  apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
  apply (auto simp add: Gamma_def)
  done

declare B_type [intro!] A_type [intro!]
declare evalc.intros [intro]

lemma com2 [rule_format]: "c \<in> com \<Longrightarrow> \<forall>x \<in> C(c). <c,fst(x)> -c-> snd(x)"
  apply (erule com.induct)
      txt \<open>\<open>skip\<close>\<close>
      apply force
     txt \<open>\<open>assign\<close>\<close>
     apply force
    txt \<open>\<open>comp\<close>\<close>
    apply force
   txt \<open>\<open>while\<close>\<close>
   apply safe
   apply simp_all
   apply (frule Gamma_bnd_mono [OF C_subset], erule Fixedpt.induct, assumption)
     unfolding Gamma_def
   apply force
  txt \<open>\<open>if\<close>\<close>
  apply auto
  done

subsection \<open>Main theorem\<close>

theorem com_equivalence:
    "c \<in> com \<Longrightarrow> C(c) = {io \<in> (loc->nat) \<times> (loc->nat). <c,fst(io)> -c-> snd(io)}"
  by (force intro: C_subset [THEN subsetD] elim: com2 dest: com1)

end


(*  Title       : NSA/NSCA.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2001,2002 University of Edinburgh
*)

section{*Non-Standard Complex Analysis*}

theory NSCA
imports NSComplex HTranscendental
begin

abbreviation
   (* standard complex numbers reagarded as an embedded subset of NS complex *)
   SComplex  :: "hcomplex set" where
   "SComplex \<equiv> Standard"

definition --{* standard part map*}
  stc :: "hcomplex => hcomplex" where
  "stc x = (SOME r. x \<in> HFinite & r:SComplex & r @= x)"

subsection{*Closure Laws for SComplex, the Standard Complex Numbers*}

lemma SComplex_minus_iff [simp]: "(-x \<in> SComplex) = (x \<in> SComplex)"
by (auto, drule Standard_minus, auto)

lemma SComplex_add_cancel:
     "[| x + y \<in> SComplex; y \<in> SComplex |] ==> x \<in> SComplex"
by (drule (1) Standard_diff, simp)

lemma SReal_hcmod_hcomplex_of_complex [simp]:
     "hcmod (hcomplex_of_complex r) \<in> Reals"
by (simp add: Reals_eq_Standard)

lemma SReal_hcmod_numeral [simp]: "hcmod (numeral w ::hcomplex) \<in> Reals"
by (simp add: Reals_eq_Standard)

lemma SReal_hcmod_SComplex: "x \<in> SComplex ==> hcmod x \<in> Reals"
by (simp add: Reals_eq_Standard)

lemma SComplex_divide_numeral:
     "r \<in> SComplex ==> r/(numeral w::hcomplex) \<in> SComplex"
by simp

lemma SComplex_UNIV_complex:
     "{x. hcomplex_of_complex x \<in> SComplex} = (UNIV::complex set)"
by simp

lemma SComplex_iff: "(x \<in> SComplex) = (\<exists>y. x = hcomplex_of_complex y)"
by (simp add: Standard_def image_def)

lemma hcomplex_of_complex_image:
     "hcomplex_of_complex `(UNIV::complex set) = SComplex"
by (simp add: Standard_def)

lemma inv_hcomplex_of_complex_image: "inv hcomplex_of_complex `SComplex = UNIV"
apply (auto simp add: Standard_def image_def)
apply (rule inj_hcomplex_of_complex [THEN inv_f_f, THEN subst], blast)
done

lemma SComplex_hcomplex_of_complex_image:
      "[| \<exists>x. x: P; P \<le> SComplex |] ==> \<exists>Q. P = hcomplex_of_complex ` Q"
apply (simp add: Standard_def, blast)
done

lemma SComplex_SReal_dense:
     "[| x \<in> SComplex; y \<in> SComplex; hcmod x < hcmod y
      |] ==> \<exists>r \<in> Reals. hcmod x< r & r < hcmod y"
apply (auto intro: SReal_dense simp add: SReal_hcmod_SComplex)
done

lemma SComplex_hcmod_SReal:
      "z \<in> SComplex ==> hcmod z \<in> Reals"
by (simp add: Reals_eq_Standard)

subsection{*The Finite Elements form a Subring*}

lemma HFinite_hcmod_hcomplex_of_complex [simp]:
     "hcmod (hcomplex_of_complex r) \<in> HFinite"
by (auto intro!: SReal_subset_HFinite [THEN subsetD])

lemma HFinite_hcmod_iff: "(x \<in> HFinite) = (hcmod x \<in> HFinite)"
by (simp add: HFinite_def)

lemma HFinite_bounded_hcmod:
  "[|x \<in> HFinite; y \<le> hcmod x; 0 \<le> y |] ==> y: HFinite"
by (auto intro: HFinite_bounded simp add: HFinite_hcmod_iff)

subsection{*The Complex Infinitesimals form a Subring*}

lemma hcomplex_sum_of_halves: "x/(2::hcomplex) + x/(2::hcomplex) = x"
by auto

lemma Infinitesimal_hcmod_iff:
   "(z \<in> Infinitesimal) = (hcmod z \<in> Infinitesimal)"
by (simp add: Infinitesimal_def)

lemma HInfinite_hcmod_iff: "(z \<in> HInfinite) = (hcmod z \<in> HInfinite)"
by (simp add: HInfinite_def)

lemma HFinite_diff_Infinitesimal_hcmod:
     "x \<in> HFinite - Infinitesimal ==> hcmod x \<in> HFinite - Infinitesimal"
by (simp add: HFinite_hcmod_iff Infinitesimal_hcmod_iff)

lemma hcmod_less_Infinitesimal:
     "[| e \<in> Infinitesimal; hcmod x < hcmod e |] ==> x \<in> Infinitesimal"
by (auto elim: hrabs_less_Infinitesimal simp add: Infinitesimal_hcmod_iff)

lemma hcmod_le_Infinitesimal:
     "[| e \<in> Infinitesimal; hcmod x \<le> hcmod e |] ==> x \<in> Infinitesimal"
by (auto elim: hrabs_le_Infinitesimal simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_interval_hcmod:
     "[| e \<in> Infinitesimal;
          e' \<in> Infinitesimal;
          hcmod e' < hcmod x ; hcmod x < hcmod e
       |] ==> x \<in> Infinitesimal"
by (auto intro: Infinitesimal_interval simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_interval2_hcmod:
     "[| e \<in> Infinitesimal;
         e' \<in> Infinitesimal;
         hcmod e' \<le> hcmod x ; hcmod x \<le> hcmod e
      |] ==> x \<in> Infinitesimal"
by (auto intro: Infinitesimal_interval2 simp add: Infinitesimal_hcmod_iff)

subsection{*The ``Infinitely Close'' Relation*}

(*
Goalw [capprox_def,approx_def] "(z @c= w) = (hcmod z @= hcmod w)"
by (auto_tac (claset(),simpset() addsimps [Infinitesimal_hcmod_iff]));
*)

lemma approx_SComplex_mult_cancel_zero:
     "[| a \<in> SComplex; a \<noteq> 0; a*x @= 0 |] ==> x @= 0"
apply (drule Standard_inverse [THEN Standard_subset_HFinite [THEN subsetD]])
apply (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
done

lemma approx_mult_SComplex1: "[| a \<in> SComplex; x @= 0 |] ==> x*a @= 0"
by (auto dest: Standard_subset_HFinite [THEN subsetD] approx_mult1)

lemma approx_mult_SComplex2: "[| a \<in> SComplex; x @= 0 |] ==> a*x @= 0"
by (auto dest: Standard_subset_HFinite [THEN subsetD] approx_mult2)

lemma approx_mult_SComplex_zero_cancel_iff [simp]:
     "[|a \<in> SComplex; a \<noteq> 0 |] ==> (a*x @= 0) = (x @= 0)"
by (blast intro: approx_SComplex_mult_cancel_zero approx_mult_SComplex2)

lemma approx_SComplex_mult_cancel:
     "[| a \<in> SComplex; a \<noteq> 0; a* w @= a*z |] ==> w @= z"
apply (drule Standard_inverse [THEN Standard_subset_HFinite [THEN subsetD]])
apply (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
done

lemma approx_SComplex_mult_cancel_iff1 [simp]:
     "[| a \<in> SComplex; a \<noteq> 0|] ==> (a* w @= a*z) = (w @= z)"
by (auto intro!: approx_mult2 Standard_subset_HFinite [THEN subsetD]
            intro: approx_SComplex_mult_cancel)

(* TODO: generalize following theorems: hcmod -> hnorm *)

lemma approx_hcmod_approx_zero: "(x @= y) = (hcmod (y - x) @= 0)"
apply (subst hnorm_minus_commute)
apply (simp add: approx_def Infinitesimal_hcmod_iff)
done

lemma approx_approx_zero_iff: "(x @= 0) = (hcmod x @= 0)"
by (simp add: approx_hcmod_approx_zero)

lemma approx_minus_zero_cancel_iff [simp]: "(-x @= 0) = (x @= 0)"
by (simp add: approx_def)

lemma Infinitesimal_hcmod_add_diff:
     "u @= 0 ==> hcmod(x + u) - hcmod x \<in> Infinitesimal"
apply (drule approx_approx_zero_iff [THEN iffD1])
apply (rule_tac e = "hcmod u" and e' = "- hcmod u" in Infinitesimal_interval2)
apply (auto simp add: mem_infmal_iff [symmetric])
apply (rule_tac c1 = "hcmod x" in add_le_cancel_left [THEN iffD1])
apply auto
done

lemma approx_hcmod_add_hcmod: "u @= 0 ==> hcmod(x + u) @= hcmod x"
apply (rule approx_minus_iff [THEN iffD2])
apply (auto intro: Infinitesimal_hcmod_add_diff simp add: mem_infmal_iff [symmetric])
done

subsection{*Zero is the Only Infinitesimal Complex Number*}

lemma Infinitesimal_less_SComplex:
   "[| x \<in> SComplex; y \<in> Infinitesimal; 0 < hcmod x |] ==> hcmod y < hcmod x"
by (auto intro: Infinitesimal_less_SReal SComplex_hcmod_SReal simp add: Infinitesimal_hcmod_iff)

lemma SComplex_Int_Infinitesimal_zero: "SComplex Int Infinitesimal = {0}"
by (auto simp add: Standard_def Infinitesimal_hcmod_iff)

lemma SComplex_Infinitesimal_zero:
     "[| x \<in> SComplex; x \<in> Infinitesimal|] ==> x = 0"
by (cut_tac SComplex_Int_Infinitesimal_zero, blast)

lemma SComplex_HFinite_diff_Infinitesimal:
     "[| x \<in> SComplex; x \<noteq> 0 |] ==> x \<in> HFinite - Infinitesimal"
by (auto dest: SComplex_Infinitesimal_zero Standard_subset_HFinite [THEN subsetD])

lemma hcomplex_of_complex_HFinite_diff_Infinitesimal:
     "hcomplex_of_complex x \<noteq> 0
      ==> hcomplex_of_complex x \<in> HFinite - Infinitesimal"
by (rule SComplex_HFinite_diff_Infinitesimal, auto)

lemma numeral_not_Infinitesimal [simp]:
     "numeral w \<noteq> (0::hcomplex) ==> (numeral w::hcomplex) \<notin> Infinitesimal"
by (fast dest: Standard_numeral [THEN SComplex_Infinitesimal_zero])

lemma approx_SComplex_not_zero:
     "[| y \<in> SComplex; x @= y; y\<noteq> 0 |] ==> x \<noteq> 0"
by (auto dest: SComplex_Infinitesimal_zero approx_sym [THEN mem_infmal_iff [THEN iffD2]])

lemma SComplex_approx_iff:
     "[|x \<in> SComplex; y \<in> SComplex|] ==> (x @= y) = (x = y)"
by (auto simp add: Standard_def)

lemma numeral_Infinitesimal_iff [simp]:
     "((numeral w :: hcomplex) \<in> Infinitesimal) =
      (numeral w = (0::hcomplex))"
apply (rule iffI)
apply (fast dest: Standard_numeral [THEN SComplex_Infinitesimal_zero])
apply (simp (no_asm_simp))
done

lemma approx_unique_complex:
     "[| r \<in> SComplex; s \<in> SComplex; r @= x; s @= x|] ==> r = s"
by (blast intro: SComplex_approx_iff [THEN iffD1] approx_trans2)

subsection {* Properties of @{term hRe}, @{term hIm} and @{term HComplex} *}

lemma abs_hRe_le_hcmod: "\<And>x. \<bar>hRe x\<bar> \<le> hcmod x"
by transfer (rule abs_Re_le_cmod)

lemma abs_hIm_le_hcmod: "\<And>x. \<bar>hIm x\<bar> \<le> hcmod x"
by transfer (rule abs_Im_le_cmod)

lemma Infinitesimal_hRe: "x \<in> Infinitesimal \<Longrightarrow> hRe x \<in> Infinitesimal"
apply (rule InfinitesimalI2, simp)
apply (rule order_le_less_trans [OF abs_hRe_le_hcmod])
apply (erule (1) InfinitesimalD2)
done

lemma Infinitesimal_hIm: "x \<in> Infinitesimal \<Longrightarrow> hIm x \<in> Infinitesimal"
apply (rule InfinitesimalI2, simp)
apply (rule order_le_less_trans [OF abs_hIm_le_hcmod])
apply (erule (1) InfinitesimalD2)
done

lemma real_sqrt_lessI: "\<lbrakk>0 < u; x < u\<^sup>2\<rbrakk> \<Longrightarrow> sqrt x < u"
(* TODO: this belongs somewhere else *)
by (frule real_sqrt_less_mono) simp

lemma hypreal_sqrt_lessI:
  "\<And>x u. \<lbrakk>0 < u; x < u\<^sup>2\<rbrakk> \<Longrightarrow> ( *f* sqrt) x < u"
by transfer (rule real_sqrt_lessI)

lemma hypreal_sqrt_ge_zero: "\<And>x. 0 \<le> x \<Longrightarrow> 0 \<le> ( *f* sqrt) x"
by transfer (rule real_sqrt_ge_zero)

lemma Infinitesimal_sqrt:
  "\<lbrakk>x \<in> Infinitesimal; 0 \<le> x\<rbrakk> \<Longrightarrow> ( *f* sqrt) x \<in> Infinitesimal"
apply (rule InfinitesimalI2)
apply (drule_tac r="r\<^sup>2" in InfinitesimalD2, simp)
apply (simp add: hypreal_sqrt_ge_zero)
apply (rule hypreal_sqrt_lessI, simp_all)
done

lemma Infinitesimal_HComplex:
  "\<lbrakk>x \<in> Infinitesimal; y \<in> Infinitesimal\<rbrakk> \<Longrightarrow> HComplex x y \<in> Infinitesimal"
apply (rule Infinitesimal_hcmod_iff [THEN iffD2])
apply (simp add: hcmod_i)
apply (rule Infinitesimal_add)
apply (erule Infinitesimal_hrealpow, simp)
apply (erule Infinitesimal_hrealpow, simp)
done

lemma hcomplex_Infinitesimal_iff:
  "(x \<in> Infinitesimal) = (hRe x \<in> Infinitesimal \<and> hIm x \<in> Infinitesimal)"
apply (safe intro!: Infinitesimal_hRe Infinitesimal_hIm)
apply (drule (1) Infinitesimal_HComplex, simp)
done

lemma hRe_diff [simp]: "\<And>x y. hRe (x - y) = hRe x - hRe y"
by transfer simp

lemma hIm_diff [simp]: "\<And>x y. hIm (x - y) = hIm x - hIm y"
by transfer simp

lemma approx_hRe: "x \<approx> y \<Longrightarrow> hRe x \<approx> hRe y"
unfolding approx_def by (drule Infinitesimal_hRe) simp

lemma approx_hIm: "x \<approx> y \<Longrightarrow> hIm x \<approx> hIm y"
unfolding approx_def by (drule Infinitesimal_hIm) simp

lemma approx_HComplex:
  "\<lbrakk>a \<approx> b; c \<approx> d\<rbrakk> \<Longrightarrow> HComplex a c \<approx> HComplex b d"
unfolding approx_def by (simp add: Infinitesimal_HComplex)

lemma hcomplex_approx_iff:
  "(x \<approx> y) = (hRe x \<approx> hRe y \<and> hIm x \<approx> hIm y)"
unfolding approx_def by (simp add: hcomplex_Infinitesimal_iff)

lemma HFinite_hRe: "x \<in> HFinite \<Longrightarrow> hRe x \<in> HFinite"
apply (auto simp add: HFinite_def SReal_def)
apply (rule_tac x="star_of r" in exI, simp)
apply (erule order_le_less_trans [OF abs_hRe_le_hcmod])
done

lemma HFinite_hIm: "x \<in> HFinite \<Longrightarrow> hIm x \<in> HFinite"
apply (auto simp add: HFinite_def SReal_def)
apply (rule_tac x="star_of r" in exI, simp)
apply (erule order_le_less_trans [OF abs_hIm_le_hcmod])
done

lemma HFinite_HComplex:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> HComplex x y \<in> HFinite"
apply (subgoal_tac "HComplex x 0 + HComplex 0 y \<in> HFinite", simp)
apply (rule HFinite_add)
apply (simp add: HFinite_hcmod_iff hcmod_i)
apply (simp add: HFinite_hcmod_iff hcmod_i)
done

lemma hcomplex_HFinite_iff:
  "(x \<in> HFinite) = (hRe x \<in> HFinite \<and> hIm x \<in> HFinite)"
apply (safe intro!: HFinite_hRe HFinite_hIm)
apply (drule (1) HFinite_HComplex, simp)
done

lemma hcomplex_HInfinite_iff:
  "(x \<in> HInfinite) = (hRe x \<in> HInfinite \<or> hIm x \<in> HInfinite)"
by (simp add: HInfinite_HFinite_iff hcomplex_HFinite_iff)

lemma hcomplex_of_hypreal_approx_iff [simp]:
     "(hcomplex_of_hypreal x @= hcomplex_of_hypreal z) = (x @= z)"
by (simp add: hcomplex_approx_iff)

lemma Standard_HComplex:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> HComplex x y \<in> Standard"
by (simp add: HComplex_def)

(* Here we go - easy proof now!! *)
lemma stc_part_Ex: "x:HFinite ==> \<exists>t \<in> SComplex. x @= t"
apply (simp add: hcomplex_HFinite_iff hcomplex_approx_iff)
apply (rule_tac x="HComplex (st (hRe x)) (st (hIm x))" in bexI)
apply (simp add: st_approx_self [THEN approx_sym])
apply (simp add: Standard_HComplex st_SReal [unfolded Reals_eq_Standard])
done

lemma stc_part_Ex1: "x:HFinite ==> EX! t. t \<in> SComplex &  x @= t"
apply (drule stc_part_Ex, safe)
apply (drule_tac [2] approx_sym, drule_tac [2] approx_sym, drule_tac [2] approx_sym)
apply (auto intro!: approx_unique_complex)
done

lemmas hcomplex_of_complex_approx_inverse =
  hcomplex_of_complex_HFinite_diff_Infinitesimal [THEN [2] approx_inverse]

subsection{*Theorems About Monads*}

lemma monad_zero_hcmod_iff: "(x \<in> monad 0) = (hcmod x:monad 0)"
by (simp add: Infinitesimal_monad_zero_iff [symmetric] Infinitesimal_hcmod_iff)

subsection{*Theorems About Standard Part*}

lemma stc_approx_self: "x \<in> HFinite ==> stc x @= x"
apply (simp add: stc_def)
apply (frule stc_part_Ex, safe)
apply (rule someI2)
apply (auto intro: approx_sym)
done

lemma stc_SComplex: "x \<in> HFinite ==> stc x \<in> SComplex"
apply (simp add: stc_def)
apply (frule stc_part_Ex, safe)
apply (rule someI2)
apply (auto intro: approx_sym)
done

lemma stc_HFinite: "x \<in> HFinite ==> stc x \<in> HFinite"
by (erule stc_SComplex [THEN Standard_subset_HFinite [THEN subsetD]])

lemma stc_unique: "\<lbrakk>y \<in> SComplex; y \<approx> x\<rbrakk> \<Longrightarrow> stc x = y"
apply (frule Standard_subset_HFinite [THEN subsetD])
apply (drule (1) approx_HFinite)
apply (unfold stc_def)
apply (rule some_equality)
apply (auto intro: approx_unique_complex)
done

lemma stc_SComplex_eq [simp]: "x \<in> SComplex ==> stc x = x"
apply (erule stc_unique)
apply (rule approx_refl)
done

lemma stc_hcomplex_of_complex:
     "stc (hcomplex_of_complex x) = hcomplex_of_complex x"
by auto

lemma stc_eq_approx:
     "[| x \<in> HFinite; y \<in> HFinite; stc x = stc y |] ==> x @= y"
by (auto dest!: stc_approx_self elim!: approx_trans3)

lemma approx_stc_eq:
     "[| x \<in> HFinite; y \<in> HFinite; x @= y |] ==> stc x = stc y"
by (blast intro: approx_trans approx_trans2 SComplex_approx_iff [THEN iffD1]
          dest: stc_approx_self stc_SComplex)

lemma stc_eq_approx_iff:
     "[| x \<in> HFinite; y \<in> HFinite|] ==> (x @= y) = (stc x = stc y)"
by (blast intro: approx_stc_eq stc_eq_approx)

lemma stc_Infinitesimal_add_SComplex:
     "[| x \<in> SComplex; e \<in> Infinitesimal |] ==> stc(x + e) = x"
apply (erule stc_unique)
apply (erule Infinitesimal_add_approx_self)
done

lemma stc_Infinitesimal_add_SComplex2:
     "[| x \<in> SComplex; e \<in> Infinitesimal |] ==> stc(e + x) = x"
apply (erule stc_unique)
apply (erule Infinitesimal_add_approx_self2)
done

lemma HFinite_stc_Infinitesimal_add:
     "x \<in> HFinite ==> \<exists>e \<in> Infinitesimal. x = stc(x) + e"
by (blast dest!: stc_approx_self [THEN approx_sym] bex_Infinitesimal_iff2 [THEN iffD2])

lemma stc_add:
     "[| x \<in> HFinite; y \<in> HFinite |] ==> stc (x + y) = stc(x) + stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_add)

lemma stc_numeral [simp]: "stc (numeral w) = numeral w"
by (rule Standard_numeral [THEN stc_SComplex_eq])

lemma stc_zero [simp]: "stc 0 = 0"
by simp

lemma stc_one [simp]: "stc 1 = 1"
by simp

lemma stc_minus: "y \<in> HFinite ==> stc(-y) = -stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_minus)

lemma stc_diff:
     "[| x \<in> HFinite; y \<in> HFinite |] ==> stc (x-y) = stc(x) - stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_diff)

lemma stc_mult:
     "[| x \<in> HFinite; y \<in> HFinite |]
               ==> stc (x * y) = stc(x) * stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_mult_HFinite)

lemma stc_Infinitesimal: "x \<in> Infinitesimal ==> stc x = 0"
by (simp add: stc_unique mem_infmal_iff)

lemma stc_not_Infinitesimal: "stc(x) \<noteq> 0 ==> x \<notin> Infinitesimal"
by (fast intro: stc_Infinitesimal)

lemma stc_inverse:
     "[| x \<in> HFinite; stc x \<noteq> 0 |]
      ==> stc(inverse x) = inverse (stc x)"
apply (drule stc_not_Infinitesimal)
apply (simp add: stc_unique stc_SComplex stc_approx_self approx_inverse)
done

lemma stc_divide [simp]:
     "[| x \<in> HFinite; y \<in> HFinite; stc y \<noteq> 0 |]
      ==> stc(x/y) = (stc x) / (stc y)"
by (simp add: divide_inverse stc_mult stc_not_Infinitesimal HFinite_inverse stc_inverse)

lemma stc_idempotent [simp]: "x \<in> HFinite ==> stc(stc(x)) = stc(x)"
by (blast intro: stc_HFinite stc_approx_self approx_stc_eq)

lemma HFinite_HFinite_hcomplex_of_hypreal:
     "z \<in> HFinite ==> hcomplex_of_hypreal z \<in> HFinite"
by (simp add: hcomplex_HFinite_iff)

lemma SComplex_SReal_hcomplex_of_hypreal:
     "x \<in> Reals ==>  hcomplex_of_hypreal x \<in> SComplex"
apply (rule Standard_of_hypreal)
apply (simp add: Reals_eq_Standard)
done

lemma stc_hcomplex_of_hypreal:
 "z \<in> HFinite ==> stc(hcomplex_of_hypreal z) = hcomplex_of_hypreal (st z)"
apply (rule stc_unique)
apply (rule SComplex_SReal_hcomplex_of_hypreal)
apply (erule st_SReal)
apply (simp add: hcomplex_of_hypreal_approx_iff st_approx_self)
done

(*
Goal "x \<in> HFinite ==> hcmod(stc x) = st(hcmod x)"
by (dtac stc_approx_self 1)
by (auto_tac (claset(),simpset() addsimps [bex_Infinitesimal_iff2 RS sym]));

approx_hcmod_add_hcmod
*)

lemma Infinitesimal_hcnj_iff [simp]:
     "(hcnj z \<in> Infinitesimal) = (z \<in> Infinitesimal)"
by (simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_hcomplex_of_hypreal_epsilon [simp]:
     "hcomplex_of_hypreal epsilon \<in> Infinitesimal"
by (simp add: Infinitesimal_hcmod_iff)

end