(* 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 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] ..

definition "c = (\<Prod>ia = 0..<m-1. (of_nat m :: real) - 1 - of_nat ia)"
lemma c_gt_0: "c > 0" unfolding c_def by (rule prod_pos, auto)
lemma c0: "c \<noteq> 0" using c_gt_0 by auto
lemma c_int_def: "c = (\<Prod>ia = 0..<m-1. (of_nat m :: int) - 1 - of_nat ia)"
  using c_def by auto
lemma c_int: "c \<in> \<int>" using c_int_def Ints_of_int by metis
lemma c_ge_1: "c \<ge> 1" using c_gt_0 unfolding c_int_def by presburger

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 I :: "nat set" where
  "I = {i | i bi li nn la. i < n \<and> j_to_jb_index n_as i = (bi, li)
    \<and> n_as ! bi = (nn,la) \<and> cmod la = 1 \<and> nn = m \<and> li = nn - 1}"

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

lemma I_nonempty: "I \<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> I" unfolding I_def unfolding sumlist_nf[symmetric] n_as using m0 by auto
  thus ?thesis by blast
qed

lemma I_n: "I \<subseteq> {..<n}" unfolding I_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 K where "K off k = D * k + (m-1) + off"

lemma mono_K: "strict_mono (K off)" unfolding strict_mono_def K_def
  using D0 by auto

definition C where "C off k = (c / real (K 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 (K off N)) $$ (i, j) * C 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 f where decomp: "decompose_prod_root_unity (char_poly A) = (ks, f)" by force
  note pf = perron_frobenius_for_complexity_jnf[OF A n0 nonneg sr1 decomp]
  define ji where "ji = j - i"
  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. (\<Prod>ia = 0..<ji. (?c N - ?c ia) / ?c (ji - ia)) * la ^ (N - ji)"
  let ?e2 = "\<lambda> N. (\<Prod>ia = 0..<ji. (?c N - ?c ia) / ?c (ji - ia)) * la ^ (N - ji) * (c / ((?c N^(m-1))))"
  define e2 where "e2 = ?e2"
  let ?e3 = "\<lambda> N. (((\<Prod>ia = 0..<ji. (?c N - ?c ia) / ?c (ji - ia))) * la ^ (N - ji)) * ?f N"
  {
    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" unfolding ji_def
        unfolding binomial_altdef_of_nat[OF ji] id ji_def
      proof (rule arg_cong[of _ _ "\<lambda> x. x * _"], rule prod.cong[OF refl], goal_cases)
      case (1 x)
        hence "x \<le> N" using \<open>N \<ge> k\<close> ij by auto
        thus ?case by (simp add: of_nat_diff)
      qed
      finally have id: "?jb N = ?e1 N" .
      have "?jbc N = e2 N"
        unfolding id e2_def using c_gt_0 by (simp add: norm_mult norm_divide norm_power)
    } note jbc = this
    have e23: "?e2 N = ?e3 N" for N using c_gt_0 by auto
    have "(e2 o K 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
        proof (intro exI[of _ "Suc ji"] impI allI, goal_cases)
          case (1 r n) thus ?case by (cases "n - ji", auto)
        qed
      next
        case small
        have e0: "e = 0 * (of_real (if m - 1 = 0 then c else 0))" using small unfolding e_def by auto
        show ?thesis unfolding e0 unfolding e23 e2_def
        proof (rule tendsto_mult[OF _ tendsto_of_real])
          show "(\<lambda>x. c / real x ^ (m - 1)) \<longlonglongrightarrow> (if m - 1 = 0 then c else 0)"
            by (cases "m - 1"; real_asymp)
          let ?laji = "inverse (la^ji)"
          let ?f = "(\<lambda>x. (\<Prod>ia = 0..<ji. (?c x - ?c ia) / ?c (ji - ia)) * la ^ (x - ji))"
          let ?g = "\<lambda>x. (\<Prod>ia = 0..<ji. (1 - ?c ia * inverse (?c x)) / ?c (ji - ia)) * (((?c x)^ji * la ^ x) * ?laji)"
          have fg: "\<forall>\<^sub>F x in sequentially. ?f x = ?g x"
            apply (rule eventually_sequentiallyI[of "Suc ji"])
            unfolding prod_pow[symmetric] prod.distrib[symmetric] mult.assoc[symmetric]
            unfolding prod_pow mult.assoc
            by (rule arg_cong2[of _ _ _ _ "(*)"], rule prod.cong, auto simp: ring_distribs,
              insert small, subst power_diff, auto simp: divide_inverse)
          have 0: "0 = (\<Prod>ia = 0..<ji. (1 - of_nat ia * 0) / of_nat (ji - ia)) * (0 * ?laji)" by simp
          show "?f \<longlonglongrightarrow> 0" unfolding tendsto_cong[OF fg]
          proof (subst 0, rule tendsto_mult[OF tendsto_prod tendsto_mult[OF _ tendsto_const]],
              intro tendsto_intros inverse_of_nat_tendsto_zero)
            show "(\<lambda>x. of_nat x ^ ji * la ^ x) \<longlonglongrightarrow> 0"
              by (rule poly_times_exp_tendsto_zero, insert small, auto)
          qed auto
        qed
      next
        case medium
        with max_block[OF kla] have "k \<le> m" and 1: "\<And> x. cmod la ^ x = 1" by auto
        with ij medium have "ji < m - 1" unfolding ji_def by linarith
        then obtain d where m1: "m - 1 = Suc d + ji" using less_iff_Suc_add by auto
        have e0: "e = 0" using medium unfolding e_def by auto
        have 0: "0 = (\<Prod>ia = 0..<ji. (1 - ?c ia * 0) / ?c (ji - ia)) * (of_real c) * 0" by simp
        let ?e = "\<lambda> ia N. if N = 0 then 0 else (1 - ?c ia / ?c N) / ?c (ji - ia)"
        let ?f = "\<lambda> ia N. (1 - ?c ia * (1 / ?c N)) / ?c (ji - ia)"
        {
          fix N
          have "e2 N = ((\<Prod>ia = 0..<ji. (?c N - ?c ia) / ?c (ji - ia)) / ?c N ^ ji) * la ^ (N - ji) * (of_real c / ?c N ^ Suc d)"
            unfolding medium m1 power_add e2_def by simp
          also have "(\<Prod>ia = 0..<ji. (?c N - ?c ia) / ?c (ji - ia)) / ?c N ^ ji
            = (\<Prod>ia = 0..<ji. ?e ia N)" unfolding prod_pow[symmetric] prod_dividef[symmetric]
            by (cases "?c N = 0", auto simp add: field_simps)
          finally have "e2 N = (\<Prod>ia = 0..<ji. ?e ia N) * of_real c * inverse (?c N ^ Suc d) * la ^ (N - ji)"
            by (simp add: divide_inverse)
          also have "cmod \<dots> = cmod ((\<Prod>ia = 0..<ji. ?e ia N) * of_real c * (inverse (?c N ^ Suc d)))"
            unfolding norm_mult norm_power 1 by simp
          finally have "cmod (e2 N) = cmod ((\<Prod>ia = 0..<ji. ?e ia N) * of_real c * (inverse (?c N ^ Suc d)))" by simp
        } note e2 = this
        show ?thesis unfolding e0
          apply (rule tendsto_norm_zero_cancel, unfold e2, rule tendsto_norm_zero)
          apply (subst (2) 0)
          apply (rule tendsto_mult[OF tendsto_mult[OF tendsto_prod tendsto_const] inverse_power_tendsto_zero], goal_cases)
        proof -
          case (1 i)
          let ?g = "\<lambda> x. (1 - ?c i * (1 / of_nat x)) / of_nat (ji - i)"
          have eq: "\<forall>\<^sub>F x in sequentially. ?e i x = ?g x"
            by (rule eventually_sequentiallyI[of 1], auto)
          show "?e i \<longlonglongrightarrow> (1 - ?c i * 0) / ?c (ji - i)"
            unfolding tendsto_cong[OF eq] using 1
            by (intro tendsto_intros lim_1_over_n, auto)
        qed
      qed
      show "(e2 o K off) \<longlonglongrightarrow> e"
        by (rule LIMSEQ_subseq_LIMSEQ[OF main mono_K])
    next
      case True
      hence large: "cmod la = 1" "k = m" "i = 0" "j = k - 1" by auto
      hence e: "e = la^off" unfolding e_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
      let ?e4 = "\<lambda> x. (\<Prod>ia = 0..<m1. 1 - ?cr (?r ia / x))"
      {
        fix x :: nat
        assume x: "x \<noteq> 0"
        have "?e2 x = ((\<Prod>ia = 0..<m1. (?c x - ?c ia) / ?c (m1 - ia)) *
            (\<Prod>ia = 0..<m1. ?cr (real m1 - real ia))) /
            (\<Prod>i = 0..<m1. ?c x) * la ^ (x - (m-1))" (is "_ = ?A / ?B * ?C")
          unfolding m1_def ji_def large c_def prod_pow[symmetric] id by simp
        also have "?A = (\<Prod>ia = 0..<m1. (?cr x - ?c ia))" (is "_ = ?A")
          unfolding prod.distrib[symmetric] by (rule prod.cong[OF refl], subst of_nat_diff, auto)
        also have "?A / ?B = (\<Prod>ia = 0..<m1. 1 - ?cr (?r ia / x))"
          unfolding prod_dividef[symmetric] by (rule prod.cong[OF refl], insert x, auto simp: field_simps)
        finally have "?e2 x = ?e4 x * ?C" .
      } note main = this
      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
      have "(\<lambda> x. ?e4 x * e) \<longlonglongrightarrow> (\<Prod>ia = 0..<m1. 1 - ?cr 0) * e"
        by (intro tendsto_intros real_tendsto_divide_at_top, auto simp: filterlim_real_sequentially)
      also have "(\<Prod>ia = 0..<m1. 1 - ?cr 0) = 1" unfolding e by simp
      finally have "(\<lambda> x. ?e4 x * e)  \<longlonglongrightarrow> e" by auto
      from LIMSEQ_subseq_LIMSEQ[OF this mono_K]
      have e4: "(\<lambda> k. (?e4 o K off) k * e) \<longlonglongrightarrow> e" (is "?A \<longlonglongrightarrow> e")
        by (auto simp: o_def)
      {
        fix k :: nat
        assume k: "k \<noteq> 0"
        hence 0: "K off k \<noteq> 0" unfolding K_def using D0 by auto
        have "?e2 (K off k) = ?e4 (K off k) * la^(K off k - (m-1))" unfolding main[OF 0] ..
        also have "K off k - (m-1) = D * k + off" unfolding K_def by simp
        also have "la ^ \<dots> = e" unfolding e power_add D power_mult 1 by auto
        finally have "e2 (K off k) = (?e4 o K off) k * e" unfolding o_def e2_def .
      } note main = this
      have id: "(?A \<longlonglongrightarrow> e) = ((e2 o K off) \<longlonglongrightarrow> e)"
        by (rule tendsto_cong, unfold eventually_at_top_linorder,
            rule exI[of _ 1], insert main, auto)
      from e4[unfolded id] show ?thesis .
    qed
    also have "((e2 o K off) \<longlonglongrightarrow> e) = ((?jbc o K 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_K[of off] 1 have "K 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 K 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_K]
    have "(?jbc o K off) \<longlonglongrightarrow> e" .
  } note part2 = this
  from part1 part2 have "(?jbc o K off) \<longlonglongrightarrow> e" by linarith
  thus ?thesis unfolding e_def o_def C_def .
qed

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

lemma cmod_Lam: "i \<in> I \<Longrightarrow> cmod (Lam i) = 1"
  unfolding I_def Lam_def by auto

lemma I_Lam: assumes i: "i \<in> I"
  shows "(m, Lam i) \<in> set n_as"
proof -
  from i[unfolded I_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: "Lam i = la" unfolding Lam_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 (K off N)) $$ (i, j) * C off N)
  \<longlonglongrightarrow> (if j \<in> I \<and> i = j - (m - 1) then (Lam 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> I" "i = j - (m - 1)"
      from this[unfolded I_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 (K off N)) $$ (i, j) * C 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> I \<and> i = j - (m - 1))" (is "?l = ?r")
    proof
      assume ?r
      hence "j \<in> I" ..
      from this[unfolded I_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> I" using bj nbj ij by (auto simp: I_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 Lam_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 C_nonneg: "C off k \<ge> 0" unfolding C_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 i where "i = (SOME i. i \<in> I)"

lemma i: "i \<in> I" unfolding i_def using I_nonempty some_in_eq by blast

lemma i_n: "i < n" using i unfolding I_def by auto

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

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

definition "B = cmod (P $$ (j, i - (m - 1))) / 2"

lemma B: "0 < B" unfolding B_def using j by auto

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

definition "v = map_vec cmod w"

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

lemma main_step: "\<exists> a. \<forall> l. 0 < Re (\<Sum>i\<in>I. a i * Lam i ^ l)"
proof -
  let ?c = "complex_of_real"
  let ?cv = "map_vec ?c"
  let ?cm = "map_mat ?c"
  let ?v = "?cv v"
  define u where "u = iP *\<^sub>v ?v"
  define cc where
    "cc = (\<lambda> i. ((\<Sum>k = 0..<n. (if k = i - (m - 1) then P $$ (j, k) else 0)) * u $v i))"
  define a where "a = (\<lambda> i. P $$ (j, i - (m - 1)) * u $v i)"
  have u: "u \<in> carrier_vec n" unfolding u_def using JNF(2) v by auto
  {
    fix off
    from i i_n have iI: "i \<in> I" and i: "i < n" by auto
    let ?exp = "\<lambda> k. sum (\<lambda> ii. P $$ (j, ii) * (J ^\<^sub>m k) $$ (ii,i)) {..<n}"
    define M where "M = (\<lambda> k. cmod (?exp (K off k) * C off k))"
    let ?i = "i - (m - 1)"
    define G where "G = (\<lambda> k. (A ^\<^sub>m K off k *\<^sub>v v) $v j * C off k)"
    {
      fix kk
      define k where "k = K 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) $ j = ((map_mat cmod cAk) *\<^sub>v map_vec cmod w) $ j"
        unfolding v_def[symmetric] cAk_def
        by (rule arg_cong[of _ _ "\<lambda> x. (x *\<^sub>v v) $ j"],
          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) $ j)"
        by (subst (1 2) index_mult_mat_vec, insert j 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 i"
        unfolding w_def i_def using JNF cAk by simp
      also have "\<dots> = P *\<^sub>v (J ^\<^sub>m k *\<^sub>v unit_vec n i)" 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 i = col (J ^\<^sub>m k) i"
        by (rule eq_vecI, insert i, auto)
      also have "(P *\<^sub>v (col (J ^\<^sub>m k) i)) $ j = Matrix.row P j \<bullet> col (J ^\<^sub>m k) i"
        by (subst index_mult_mat_vec, insert j JNF, auto)
      also have "\<dots> = sum (\<lambda> ii. P $$ (j, ii) * (J ^\<^sub>m k) $$ (ii,i)) {..<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 j \<ge> cmod (?exp k)" .
      from mult_right_mono[OF this C_nonneg]
      have "(A ^\<^sub>m k *\<^sub>v v) $v j * C off kk \<ge> cmod (?exp k * C off kk)" unfolding norm_mult
        using C_nonneg by auto
    }
    hence ge: "(A ^\<^sub>m K off k *\<^sub>v v) $v j * C off k \<ge> M k" for k unfolding M_def by auto
    from i have mem: "i - (m - 1) \<in> {..<n}" by auto
    have "(\<lambda> k. ?exp (K off k) * C off k) \<longlonglongrightarrow>
      (\<Sum>ii<n. P $$ (j, ii) * (if i \<in> I \<and> ii = i - (m - 1) then Lam i ^ 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 _ i], auto)
    also have "?sum = P $$ (j, i - (m - 1)) * Lam i ^ off"
      by (subst sum.remove[OF _ mem], force, subst sum.neutral, insert iI, auto)
    finally have tend1: "(\<lambda> k. ?exp (K off k) * C off k) \<longlonglongrightarrow> P $$ (j, i - (m - 1)) * Lam i ^ off" .
    have tend2: "M \<longlonglongrightarrow> cmod (P $$ (j, i - (m - 1)) * Lam i ^ off)" unfolding M_def
      by (rule tendsto_norm, rule tend1)
    {
      from j have 0: "P $$ (j, i - (m - 1)) \<noteq> 0" by auto
      define E where "E = cmod (P $$ (j, i - (m - 1)) * Lam i ^ off)"
      from cmod_Lam[OF iI] 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_Lam[OF iI] 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
    {
      fix kk
      define k where "k = K off kk"
      have "((A ^\<^sub>m k) *\<^sub>v v) $ j * C off kk = Re (?c (((A ^\<^sub>m k) *\<^sub>v v) $ j * C off kk))" by simp
      also have "?c (((A ^\<^sub>m k) *\<^sub>v v) $ j * C off kk) = ?cv ((A ^\<^sub>m k) *\<^sub>v v) $ j * ?c (C off kk)"
        using j 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 j * C off kk = Re ((P *\<^sub>v (J ^\<^sub>m k *\<^sub>v u)) $ j * C off kk)" by simp
      also have "\<dots> = Re (\<Sum>i = 0..<n.
           P $$ (j, i) * (\<Sum>ia = 0..< n. (J ^\<^sub>m k) $$ (i, ia) * u $v ia * C off kk))"
        by (subst index_mult_mat_vec, insert JNF(1) j u, auto simp: scalar_prod_def sum_distrib_right[symmetric]
           mult.assoc[symmetric])
      finally have "(A ^\<^sub>m k *\<^sub>v v) $v j * C off kk =
        Re (\<Sum>i = 0..<n. P $$ (j, i) * (\<Sum>ia = 0..<n. (J ^\<^sub>m k) $$ (i, ia) * C off kk * u $v ia))"
        unfolding k_def
        by (simp only: ac_simps)
    } note A_to_u = this
    define F where "F = (\<Sum>ia\<in>I. a ia * Lam ia ^ off)"
    have "G \<longlonglongrightarrow>
       Re (\<Sum>i = 0..<n. P $$ (j, i) *
           (\<Sum>ia = 0..<n. (if ia \<in> I \<and> i = ia - (m - 1) then (Lam ia)^off else 0) * u $v ia))"
      unfolding A_to_u G_def
      by (rule tendsto_Re[OF tendsto_sum[OF tendsto_mult[OF _
        tendsto_sum[OF tendsto_mult[OF limit_jordan_matrix]]]]], auto)
    also have "(\<Sum>i = 0..<n. P $$ (j, i) *
           (\<Sum>ia = 0..<n. (if ia \<in> I \<and> i = ia - (m - 1) then (Lam ia)^off else 0) * u $v ia))
      = (\<Sum>i = 0..<n. (\<Sum>ia \<in> I. (if ia \<in> I \<and> i = ia - (m - 1) then P $$ (j, i) else 0) * ((Lam 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 I_n, auto intro!: sum.cong)
    also have "\<dots> = (\<Sum>ia \<in> I. (\<Sum>i = 0..<n. (if i = ia - (m - 1) then P $$ (j, i) else 0)) * ((Lam ia)^off * u $v ia))"
      unfolding sum.swap[of _ I] sum_distrib_right
      by (rule sum.cong[OF refl], auto)
    also have "\<dots> = (\<Sum>ia \<in> I. cc ia * (Lam 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 I_n, auto)
    finally have tend3: "G \<longlonglongrightarrow> Re F" .
    from this[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 obtain a where pos: "\<And> l. 0 < Re (\<Sum>i\<in>I. a i * Lam i ^ l)" by auto
  have "1 \<in> Lam ` I"
  proof (rule sum_root_unity_power_pos_implies_1[of a Lam I, OF pos])
    fix i
    assume "i \<in> I"
    from d[OF I_Lam[OF this] cmod_Lam[OF this]]
    show "\<exists>d. d \<noteq> 0 \<and> Lam i ^ d = 1" by auto
  qed
  then obtain i where i: "i \<in> I" and "Lam i = 1" by auto
  with I_Lam[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 Lam where M: "(M,Lam) \<in> set n_as" "cmod Lam = 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 Lam
  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


theory Exercise7p1
imports Bigstep_sseefried
begin

fun assigned :: "com \<Rightarrow> vname set" where
    "assigned SKIP = {}"
  | "assigned (Assign v _) = {v}"
  | "assigned (Seq c1 c2) = assigned c1 \<union> assigned c2"
  | "assigned (If b c1 c2) = assigned c1 \<union> assigned c2"
  | "assigned (While b c) = assigned c"

lemma "\<lbrakk> (c,s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
  by (induction rule: big_step_induct, auto)

(* lemma "\<lbrakk> (c,s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
proof (induction arbitrary: s t rule: assigned.induct)
  -- "Seq case"
  fix c1 c2 s t
  assume h1: "(\<And>s t. (c1, s) \<Rightarrow> t \<Longrightarrow> x \<notin> assigned c1 \<Longrightarrow> s x = t x)"
  assume h2: "(\<And>s t. (c2, s) \<Rightarrow> t \<Longrightarrow> x \<notin> assigned c2 \<Longrightarrow> s x = t x)"
  assume h3: "(c1;; c2, s) \<Rightarrow> t"
  assume h4: "x \<notin> assigned (c1;; c2)"
  then have r1: "\<exists>s'. (c1, s) \<Rightarrow> s' \<and> (c2, s') \<Rightarrow> t" using h3 by blast
  obtain s' where x: "(c1, s) \<Rightarrow> s' \<and> (c2, s') \<Rightarrow> t" using r1 by blast
  then have a: "s x = s' x" using x h1 h4 by fastforce
  then have b: "s' x = t x" using x h2 h4 by fastforce
  then show "s x = t x" using a by fastforce
next -- "WHILE case"
  fix b c s t
  assume h1: "\<And>s t. (c, s) \<Rightarrow> t \<Longrightarrow> x \<notin> assigned c \<Longrightarrow> s x = t x"
  assume h2: "(WHILE b DO c, s) \<Rightarrow> t"
  assume h3: "x \<notin> assigned (WHILE b DO c)"
  then have "(bval b s \<and> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t))
             \<or> (\<not>bval b s \<and> t = s)" using h2 by auto
  then show "s x = t x"
  proof
    assume "bval b s \<and> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t)"
    then obtain s' where "(c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t" by auto
    then show "s x = t x" using h1 h2 h3 sorry
  next
    assume "\<not>bval b s \<and> t = s"
    then show "s x = t x" by blast
  qed
qed auto -- "Rest of the cases are trivial" *)

end


(*  Title:      HOL/HOLCF/Library/Defl_Bifinite.thy
    Author:     Brian Huffman
*)

section {* Algebraic deflations are a bifinite domain *}

theory Defl_Bifinite
imports HOLCF "~~/src/HOL/Library/Infinite_Set"
begin

subsection {* Lemmas about MOST *}

default_sort type

lemma MOST_INFM:
  assumes inf: "infinite (UNIV::'a set)"
  shows "MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
  unfolding Alm_all_def Inf_many_def
  apply (auto simp add: Collect_neg_eq)
  apply (drule (1) finite_UnI)
  apply (simp add: Compl_partition2 inf)
  done

lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
by (rule MOST_inj [OF _ inj_Suc])

lemma MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
unfolding MOST_nat
apply (clarify, rule_tac x="Suc m" in exI, clarify)
apply (erule Suc_lessE, simp)
done

lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
by (rule iffI [OF MOST_SucD MOST_SucI])

lemma INFM_finite_Bex_distrib:
  "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)"
by (induct set: finite, simp, simp add: INFM_disj_distrib)

lemma MOST_finite_Ball_distrib:
  "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)"
by (induct set: finite, simp, simp add: MOST_conj_distrib)

lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
unfolding MOST_nat_le by fast

subsection {* Eventually constant sequences *}

definition
  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "eventually_constant S = (\<exists>x. MOST i. S i = x)"

lemma eventually_constant_MOST_MOST:
  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
unfolding eventually_constant_def MOST_nat
apply safe
apply (rule_tac x=m in exI, clarify)
apply (rule_tac x=m in exI, clarify)
apply simp
apply fast
done

lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
unfolding eventually_constant_def by fast

lemma eventually_constant_comp:
  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
unfolding eventually_constant_def
apply (erule exE, rule_tac x="f x" in exI)
apply (erule MOST_mono, simp)
done

lemma eventually_constant_Suc_iff:
  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
unfolding eventually_constant_def
by (subst MOST_Suc_iff, rule refl)

lemma eventually_constant_SucD:
  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
by (rule eventually_constant_Suc_iff [THEN iffD1])

subsection {* Limits of eventually constant sequences *}

definition
  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
  "eventual S = (THE x. MOST i. S i = x)"

lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
unfolding eventual_def
apply (rule the_equality, assumption)
apply (rename_tac y)
apply (subgoal_tac "MOST i::nat. y = x", simp)
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma MOST_eq_eventual:
  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
unfolding eventually_constant_def
by (erule exE, simp add: eventual_eqI)

lemma eventual_mem_range:
  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
apply (drule MOST_eq_eventual)
apply (simp only: MOST_nat_le, clarify)
apply (drule spec, drule mp, rule order_refl)
apply (erule range_eqI [OF sym])
done

lemma eventually_constant_MOST_iff:
  assumes S: "eventually_constant S"
  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
apply simp
apply (rule iffI)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, force)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, simp)
done

lemma MOST_eventual:
  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
proof -
  assume "eventually_constant S"
  hence "MOST n. S n = eventual S"
    by (rule MOST_eq_eventual)
  moreover assume "MOST n. P (S n)"
  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
  hence "MOST n::nat. P (eventual S)"
    by (rule MOST_mono) auto
  thus ?thesis by simp
qed

lemma eventually_constant_MOST_Suc_eq:
  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
apply (drule MOST_eq_eventual)
apply (frule MOST_Suc_iff [THEN iffD2])
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma eventual_comp:
  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
apply (rule eventual_eqI)
apply (rule MOST_mono)
apply (erule MOST_eq_eventual)
apply simp
done

subsection {* Constructing finite deflations by iteration *}

default_sort cpo

lemma le_Suc_induct:
  assumes le: "i \<le> j"
  assumes step: "\<And>i. P i (Suc i)"
  assumes refl: "\<And>i. P i i"
  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
  shows "P i j"
proof (cases "i = j")
  assume "i = j"
  thus "P i j" by (simp add: refl)
next
  assume "i \<noteq> j"
  with le have "i < j" by simp
  thus "P i j" using step trans by (rule less_Suc_induct)
qed

definition
  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
where
  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"

text {* A pre-deflation is like a deflation, but not idempotent. *}

locale pre_deflation =
  fixes f :: "'a \<rightarrow> 'a::cpo"
  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
begin

lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
by (induct i, simp_all add: below_trans [OF below])

lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
by (induct i, simp_all)

lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
apply (erule le_Suc_induct)
apply (simp add: below)
apply (rule below_refl)
apply (erule (1) below_trans)
done

lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
proof (rule finite_subset)
  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
    by (clarify, case_tac i, simp_all)
  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
    by (simp add: finite_range)
qed

lemma eventually_constant_iterate_app:
  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
unfolding eventually_constant_def MOST_nat_le
proof -
  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
    apply (rule finite_range_has_max)
    apply (erule antichain_iterate_app)
    apply (rule finite_range_iterate_app)
    done
  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
  proof (intro exI allI impI)
    fix k
    assume "j \<le> k"
    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
    finally show "?Y k = ?Y j" .
  qed
qed

lemma eventually_constant_iterate:
  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
proof -
  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
    by (simp add: eventually_constant_iterate_app)
  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    unfolding eventually_constant_MOST_MOST .
  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
    by simp
  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
    by (simp only: iterate_Suc2)
  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
    by (simp only: cfun_eq_iff)
  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
    unfolding eventually_constant_MOST_MOST .
  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
    by (rule eventually_constant_SucD)
qed

abbreviation
  d :: "'a \<rightarrow> 'a"
where
  "d \<equiv> eventual_iterate f"

lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
unfolding eventual_iterate_def
using eventually_constant_iterate by (rule MOST_eventual)

lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
apply (rule MOST_d)
apply (subst iterate_Suc [symmetric])
apply (rule eventually_constant_MOST_Suc_eq)
apply (rule eventually_constant_iterate_app)
done

lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
proof
  assume "d\<cdot>x = x"
  with f_d [where x=x]
  show "f\<cdot>x = x" by simp
next
  assume f: "f\<cdot>x = x"
  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
    by (rule allI, rule nat.induct, simp, simp add: f)
  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
    by (rule ALL_MOST)
  thus "d\<cdot>x = x"
    by (rule MOST_d)
qed

lemma finite_deflation_d: "finite_deflation d"
proof
  fix x :: 'a
  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
    unfolding eventual_iterate_def
    using eventually_constant_iterate
    by (rule eventual_mem_range)
  then obtain n where n: "d = iterate n\<cdot>f" ..
  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
    using f_d by (rule iterate_fixed)
  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
    by (simp add: n)
next
  fix x :: 'a
  show "d\<cdot>x \<sqsubseteq> x"
    by (rule MOST_d, simp add: iterate_below)
next
  from finite_range
  have "finite {x. f\<cdot>x = x}"
    by (rule finite_range_imp_finite_fixes)
  thus "finite {x. d\<cdot>x = x}"
    by (simp add: d_fixed_iff)
qed

lemma deflation_d: "deflation d"
using finite_deflation_d
by (rule finite_deflation_imp_deflation)

end

lemma finite_deflation_eventual_iterate:
  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
by (rule pre_deflation.finite_deflation_d)

lemma pre_deflation_oo:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "pre_deflation (d oo f)"
proof
  interpret d: finite_deflation d by fact
  fix x
  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
    by (simp, rule below_trans [OF d.below f])
  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
    by (rule finite_subset [OF _ d.finite_range], auto)
qed

lemma eventual_iterate_oo_fixed_iff:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
proof -
  interpret d: finite_deflation d by fact
  let ?e = "d oo f"
  interpret e: pre_deflation "d oo f"
    using `finite_deflation d` f
    by (rule pre_deflation_oo)
  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
  show ?thesis
    apply (subst e.d_fixed_iff)
    apply simp
    apply safe
    apply (erule subst)
    apply (rule d.idem)
    apply (rule below_antisym)
    apply (rule f)
    apply (erule subst, rule d.below)
    apply simp
    done
qed

lemma eventual_mono:
  assumes A: "eventually_constant A"
  assumes B: "eventually_constant B"
  assumes below: "\<And>n. A n \<sqsubseteq> B n"
  shows "eventual A \<sqsubseteq> eventual B"
proof -
  from A have "MOST n. A n = eventual A"
    by (rule MOST_eq_eventual)
  then have "MOST n. eventual A \<sqsubseteq> B n"
    by (rule MOST_mono) (erule subst, rule below)
  with B show "eventual A \<sqsubseteq> eventual B"
    by (rule MOST_eventual)
qed

lemma eventual_iterate_mono:
  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
unfolding eventual_iterate_def
apply (rule eventual_mono)
apply (rule pre_deflation.eventually_constant_iterate [OF f])
apply (rule pre_deflation.eventually_constant_iterate [OF g])
apply (rule monofun_cfun_arg [OF `f \<sqsubseteq> g`])
done

lemma cont2cont_eventual_iterate_oo:
  assumes d: "finite_deflation d"
  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
    (is "cont ?e")
proof (rule contI2)
  show "monofun ?e"
    apply (rule monofunI)
    apply (rule eventual_iterate_mono)
    apply (rule pre_deflation_oo [OF d below])
    apply (rule pre_deflation_oo [OF d below])
    apply (rule monofun_cfun_arg)
    apply (erule cont2monofunE [OF cont])
    done
next
  fix Y :: "nat \<Rightarrow> 'b"
  assume Y: "chain Y"
  with cont have fY: "chain (\<lambda>i. f (Y i))"
    by (rule ch2ch_cont)
  assume eY: "chain (\<lambda>i. ?e (Y i))"
  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
    by (rule admD [OF _ Y], simp add: cont, rule below)
  have "deflation (?e (\<Squnion>i. Y i))"
    apply (rule pre_deflation.deflation_d)
    apply (rule pre_deflation_oo [OF d lub_below])
    done
  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
  proof (rule deflation.belowI)
    fix x :: 'a
    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
      apply (simp only: cont2contlubE [OF cont Y])
      apply (simp only: contlub_cfun_fun [OF fY])
      done
    have "compact (d\<cdot>x)"
      using d by (rule finite_deflation.compact)
    then have "compact x"
      using `d\<cdot>x = x` by simp
    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` by simp
    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
    then have "f (Y n)\<cdot>x = x"
      using `(\<Squnion>i. f (Y i)\<cdot>x) = x` fY by (simp add: maxinch_is_thelub)
    with `d\<cdot>x = x` have "?e (Y n)\<cdot>x = x"
      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
      by (rule is_ub_thelub, simp add: eY)
    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
      by (simp add: contlub_cfun_fun eY)
    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
      apply (rule deflation.below)
      apply (rule admD [OF adm_deflation eY])
      apply (rule pre_deflation.deflation_d)
      apply (rule pre_deflation_oo [OF d below])
      done
    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
  qed
qed

subsection {* Intersection of algebraic deflations *}

default_sort bifinite

definition meet_fin_defl :: "'a fin_defl \<Rightarrow> 'a fin_defl \<Rightarrow> 'a fin_defl"
  where "meet_fin_defl a b =
    Abs_fin_defl (eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b))"

lemma Rep_meet_fin_defl:
  "Rep_fin_defl (meet_fin_defl a b) =
    eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b)"
unfolding meet_fin_defl_def
apply (rule Abs_fin_defl_inverse [simplified])
apply (rule finite_deflation_eventual_iterate)
apply (rule pre_deflation_oo)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma Rep_meet_fin_defl_fixed_iff:
  "Rep_fin_defl (meet_fin_defl a b)\<cdot>x = x \<longleftrightarrow>
    Rep_fin_defl a\<cdot>x = x \<and> Rep_fin_defl b\<cdot>x = x"
unfolding Rep_meet_fin_defl
apply (rule eventual_iterate_oo_fixed_iff)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma meet_fin_defl_mono:
  "\<lbrakk>a \<sqsubseteq> b; c \<sqsubseteq> d\<rbrakk> \<Longrightarrow> meet_fin_defl a c \<sqsubseteq> meet_fin_defl b d"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below1: "meet_fin_defl a b \<sqsubseteq> a"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below2: "meet_fin_defl a b \<sqsubseteq> b"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_fin_defl b c"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

definition meet_defl :: "'a defl \<rightarrow> 'a defl \<rightarrow> 'a defl"
  where "meet_defl = defl.extension (\<lambda>a. defl.extension (\<lambda>b.
    defl_principal (meet_fin_defl a b)))"

lemma meet_defl_principal:
  "meet_defl\<cdot>(defl_principal a)\<cdot>(defl_principal b) =
    defl_principal (meet_fin_defl a b)"
unfolding meet_defl_def
by (simp add: defl.extension_principal defl.extension_mono meet_fin_defl_mono)

lemma meet_defl_below1: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> a"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below1)
done

lemma meet_defl_below2: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> b"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below2)
done

lemma meet_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_defl\<cdot>b\<cdot>c"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (induct c rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_greatest)
done

lemma meet_defl_eq2: "b \<sqsubseteq> a \<Longrightarrow> meet_defl\<cdot>a\<cdot>b = b"
by (fast intro: below_antisym meet_defl_below2 meet_defl_greatest)

interpretation meet_defl: semilattice "\<lambda>a b. meet_defl\<cdot>a\<cdot>b"
by default
  (fast intro: below_antisym meet_defl_greatest
   meet_defl_below1 [THEN below_trans] meet_defl_below2 [THEN below_trans])+

lemma deflation_meet_defl: "deflation (meet_defl\<cdot>a)"
apply (rule deflation.intro)
apply (rule meet_defl.left_idem)
apply (rule meet_defl_below2)
done

lemma finite_deflation_meet_defl:
  assumes "compact a"
  shows "finite_deflation (meet_defl\<cdot>a)"
proof (rule finite_deflation_intro)
  obtain d where a: "a = defl_principal d"
    using defl.compact_imp_principal [OF assms] ..
  have "finite (defl_set -` Pow (defl_set a))"
    apply (rule finite_vimageI)
    apply (rule finite_Pow_iff [THEN iffD2])
    apply (simp add: defl_set_def a cast_defl_principal Abs_fin_defl_inverse)
    apply (rule Rep_fin_defl.finite_fixes)
    apply (rule injI)
    apply (simp add: po_eq_conv defl_set_subset_iff [symmetric])
    done
  hence "finite (range (\<lambda>b. meet_defl\<cdot>a\<cdot>b))"
    apply (rule rev_finite_subset)
    apply (clarsimp, erule rev_subsetD)
    apply (simp add: defl_set_subset_iff meet_defl_below1)
    done
  thus "finite {b. meet_defl\<cdot>a\<cdot>b = b}"
    by (rule finite_range_imp_finite_fixes)
qed (rule deflation_meet_defl)

lemma compact_iff_finite_deflation_cast:
  "compact d \<longleftrightarrow> finite_deflation (cast\<cdot>d)"
apply (safe dest!: defl.compact_imp_principal)
apply (simp add: cast_defl_principal finite_deflation_Rep_fin_defl)
apply (rule compact_cast_iff [THEN iffD1])
apply (erule finite_deflation_imp_compact)
done

lemma compact_iff_finite_defl_set:
  "compact d \<longleftrightarrow> finite (defl_set d)"
by (simp add: compact_iff_finite_deflation_cast defl_set_def
  finite_deflation_def deflation_cast finite_deflation_axioms_def)

lemma compact_meet_defl1: "compact a \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
apply (simp add: compact_iff_finite_defl_set)
apply (erule rev_finite_subset)
apply (simp add: defl_set_subset_iff meet_defl_below1)
done

lemma compact_meet_defl2: "compact b \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
by (subst meet_defl.commute, rule compact_meet_defl1)

subsection {* Chain of approx functions on algebraic deflations *}

context bifinite_approx_chain
begin

definition defl_approx :: "nat \<Rightarrow> 'a defl \<rightarrow> 'a defl"
  where "defl_approx i = meet_defl\<cdot>(defl_principal (Abs_fin_defl (approx i)))"

lemma defl_approx: "approx_chain defl_approx"
proof (rule approx_chain.intro)
  have chain1: "chain (\<lambda>i. defl_principal (Abs_fin_defl (approx i)))"
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def Abs_fin_defl_inverse)
    apply (rule chainE [OF chain_approx])
    done
  show chain: "chain (\<lambda>i. defl_approx i)"
    unfolding defl_approx_def by (simp add: chain1)
  have below: "\<And>i d. defl_approx i\<cdot>d \<sqsubseteq> d"
    unfolding defl_approx_def by (rule meet_defl_below2)
  show "(\<Squnion>i. defl_approx i) = ID"
    apply (rule cfun_eqI, rename_tac d, simp)
    apply (rule below_antisym)
    apply (simp add: contlub_cfun_fun chain)
    apply (simp add: lub_below chain below)
    apply (simp add: defl_approx_def)
    apply (simp add: lub_distribs chain1)
    apply (rule meet_defl_greatest [OF _ below_refl])
    apply (rule cast_below_imp_below)
    apply (simp add: contlub_cfun_arg chain1)
    apply (simp add: cast_defl_principal Abs_fin_defl_inverse)
    apply (rule cast.below_ID)
    done
  show "\<And>i. finite_deflation (defl_approx i)"
    unfolding defl_approx_def
    apply (rule finite_deflation_meet_defl)
    apply (rule defl.compact_principal)
    done
qed

end

subsection {* Algebraic deflations are a bifinite domain *}

instance defl :: (bifinite) bifinite
proof
  obtain a :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain a"
    using bifinite ..
  hence "bifinite_approx_chain a"
    unfolding bifinite_approx_chain_def .
  thus "\<exists>(a::nat \<Rightarrow> 'a defl \<rightarrow> 'a defl). approx_chain a"
    by (fast intro: bifinite_approx_chain.defl_approx)
qed

subsection {* Algebraic deflations are representable *}

default_sort "domain"

definition defl_emb :: "udom defl \<rightarrow> udom"
  where "defl_emb = udom_emb (bifinite_approx_chain.defl_approx udom_approx)"

definition defl_prj :: "udom \<rightarrow> udom defl"
  where "defl_prj = udom_prj (bifinite_approx_chain.defl_approx udom_approx)"

lemma ep_pair_defl: "ep_pair defl_emb defl_prj"
unfolding defl_emb_def defl_prj_def
apply (rule ep_pair_udom)
apply (rule bifinite_approx_chain.defl_approx)
apply (simp add: bifinite_approx_chain_def)
done

text "Deflation combinator for deflation type constructor"

definition defl_defl :: "udom defl \<rightarrow> udom defl"
  where defl_deflation_def:
  "defl_defl = defl.extension (\<lambda>a. defl_principal
    (Abs_fin_defl (defl_emb oo meet_defl\<cdot>(defl_principal a) oo defl_prj)))"

lemma cast_defl_defl:
  "cast\<cdot>(defl_defl\<cdot>a) = defl_emb oo meet_defl\<cdot>a oo defl_prj"
apply (induct a rule: defl.principal_induct, simp)
apply (subst defl_deflation_def)
apply (subst defl.extension_principal)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
apply (simp add: cast_defl_principal
  below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
done

definition defl_map_emb :: "'a::domain defl \<rightarrow> udom defl"
  where "defl_map_emb = defl_fun1 emb prj ID"

definition defl_map_prj :: "udom defl \<rightarrow> 'a::domain defl"
  where "defl_map_prj = defl.extension (\<lambda>a. defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb)))"

lemma defl_map_emb_principal:
  "defl_map_emb\<cdot>(defl_principal a) =
    defl_principal (Abs_fin_defl (emb oo Rep_fin_defl a oo prj))"
unfolding defl_map_emb_def defl_fun1_def
apply (subst defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse monofun_cfun
       domain.finite_deflation_e_d_p finite_deflation_Rep_fin_defl)
apply simp
done

lemma defl_map_prj_principal:
  "(defl_map_prj\<cdot>(defl_principal a) :: 'a::domain defl) =
  defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb))"
unfolding defl_map_prj_def
apply (rule defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (simp add: monofun_cfun below_fin_defl_def)
done

lemma defl_map_prj_defl_map_emb: "defl_map_prj\<cdot>(defl_map_emb\<cdot>d) = d"
apply (rule cast_eq_imp_eq)
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_emb_principal)
apply (subst defl_map_prj_principal)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst meet_defl_eq2)
apply (rule cast_below_imp_below)
apply (simp add: cast_DEFL)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule cfun_belowI, simp)
apply (rule Rep_fin_defl.below)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (simp add: cfun_eqI)
done

lemma defl_map_emb_defl_map_prj:
  "defl_map_emb\<cdot>(defl_map_prj\<cdot>d :: 'a defl) = meet_defl\<cdot>DEFL('a)\<cdot>d"
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_prj_principal)
apply (subst defl_map_emb_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (rule cast_eq_imp_eq)
apply (subst cast_defl_principal)
apply (simp add: cfcomp1 emb_prj)
apply (subst deflation_below_comp2 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (subst deflation_below_comp1 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (simp add: eta_cfun)
apply (rule Abs_fin_defl_inverse, simp)
apply (rule finite_deflation_cast)
apply (rule compact_meet_defl2, simp)
done

lemma ep_pair_defl_map_emb_defl_map_prj:
  "ep_pair defl_map_emb defl_map_prj"
apply (rule ep_pair.intro)
apply (rule defl_map_prj_defl_map_emb)
apply (simp add: defl_map_emb_defl_map_prj)
apply (rule meet_defl_below2)
done

instantiation defl :: ("domain") "domain"
begin

definition
  "emb = defl_emb oo defl_map_emb"

definition
  "prj = defl_map_prj oo defl_prj"

definition
  "defl (t::'a defl itself) = defl_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a defl u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a defl u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a defl itself) = liftdefl_of\<cdot>DEFL('a defl)"

instance proof
  show ep: "ep_pair emb (prj :: udom \<rightarrow> 'a defl)"
    unfolding emb_defl_def prj_defl_def
    apply (rule ep_pair_comp [OF _ ep_pair_defl])
    apply (rule ep_pair_defl_map_emb_defl_map_prj)
    done
  show "cast\<cdot>DEFL('a defl) = emb oo (prj :: udom \<rightarrow> 'a defl)"
    unfolding defl_defl_def emb_defl_def prj_defl_def
    by (simp add: cast_defl_defl cfcomp1 defl_map_emb_defl_map_prj)
qed (fact liftemb_defl_def liftprj_defl_def liftdefl_defl_def)+

end

lemma DEFL_defl [domain_defl_simps]: "DEFL('a defl) = defl_defl\<cdot>DEFL('a)"
by (rule defl_defl_def)

end