(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Jordan Normal Form\<close>

text \<open>This theory defines Jordan normal forms (JNFs) in a sparse representation, i.e.,
  as block-diagonal matrices. We also provide a closed formula for powers of JNFs,
  which allows to estimate the growth rates of JNFs.\<close>

theory Jordan_Normal_Form
imports
  Matrix
  Char_Poly
  Polynomial_Interpolation.Missing_Unsorted
begin

definition jordan_block :: "nat \<Rightarrow> 'a :: {zero,one} \<Rightarrow> 'a mat" where
  "jordan_block n a = mat n n (\<lambda> (i,j). if i = j then a else if Suc i = j then 1 else 0)"

lemma jordan_block_index[simp]: "i < n \<Longrightarrow> j < n \<Longrightarrow>
  jordan_block n a $$ (i,j) = (if i = j then a else if Suc i = j then 1 else 0)"
  "dim_row (jordan_block n k) = n"
  "dim_col (jordan_block n k) = n"
  unfolding jordan_block_def by auto

lemma jordan_block_carrier[simp]: "jordan_block n k \<in> carrier_mat n n"
  unfolding carrier_mat_def by auto

lemma jordan_block_char_poly: "char_poly (jordan_block n a) = [: -a, 1:]^n"
  unfolding char_poly_defs by (subst det_upper_triangular[of _ n], auto simp: prod_list_diag_prod)

lemma jordan_block_pow_carrier[simp]:
  "jordan_block n a ^\<^sub>m r \<in> carrier_mat n n" by auto
lemma jordan_block_pow_dim[simp]:
  "dim_row (jordan_block n a ^\<^sub>m r) = n" "dim_col (jordan_block n a ^\<^sub>m r) = n" by auto

lemma jordan_block_pow: "(jordan_block n (a :: 'a :: comm_ring_1)) ^\<^sub>m r =
  mat n n (\<lambda> (i,j). if i \<le> j then of_nat (r choose (j - i)) * a ^ (r + i - j) else 0)"
proof (induct r)
  case 0
  {
    fix i j :: nat
    assume "i \<noteq> j" "i \<le> j"
    hence "j - i > 0" by auto
    hence "0 choose (j - i) = 0" by simp
  } note [simp] = this
  show ?case
    by (simp, rule eq_matI, auto)
next
  case (Suc r)
  let ?jb = "jordan_block n a"
  let ?rij = "\<lambda> r i j. of_nat (r choose (j - i)) * a ^ (r + i - j)"
  let ?v = "\<lambda> i j. if i \<le> j then of_nat (r choose (j - i)) * a ^ (r + i - j) else 0"
  have "?jb ^\<^sub>m Suc r = mat n n (\<lambda> (i,j). if i \<le> j then ?rij r i j else 0) * ?jb" by (simp add: Suc)
  also have "\<dots> = mat n n (\<lambda> (i,j). if i \<le> j then ?rij (Suc r) i j else 0)"
  proof -
    {
      fix j
      assume j: "j < n"
      hence col: "col (jordan_block n a) j = vec n (\<lambda>i. if i = j then a else if Suc i = j then 1 else 0)"
        unfolding jordan_block_def col_mat[OF j] by simp
      fix f
      have "vec n f \<bullet> col (jordan_block n a) j = (f j * a + (if j = 0 then 0 else f (j - 1)))"
      proof -
        define p where "p = (\<lambda> i. vec n f $ i * col (jordan_block n a) j $ i)"
        have "vec n f \<bullet> col (jordan_block n a) j = (\<Sum>i = 0 ..< n. p i)"
          unfolding scalar_prod_def p_def by simp
        also have "\<dots> = p j + sum p ({0 ..< n} - {j})" using j
          by (subst sum.remove[of _ j], auto)
        also have "p j = f j * a" unfolding p_def col using j by auto
        also have "sum p ({0 ..< n} - {j}) = (if j = 0 then 0 else f (j - 1))"
        proof (cases j)
          case 0
          have "sum p ({0 ..< n} - {j}) = 0"
            by (rule sum.neutral, auto simp: p_def col 0)
          thus ?thesis using 0 by simp
        next
          case (Suc jj)
          with j have jj: "jj \<in> {0 ..< n} - {j}" by auto
          have "sum p ({0 ..< n} - {j}) = p jj + sum p ({0 ..< n} - {j} - {jj})"
            by (subst sum.remove[OF _ jj], auto)
          also have "p jj = f (j - 1)" unfolding p_def col using jj
            by (auto simp: Suc)
          also have "sum p ({0 ..< n} - {j} - {jj}) = 0"
            by (rule sum.neutral, auto simp: p_def col, auto simp: Suc)
          finally show ?thesis unfolding Suc by simp
        qed
        finally show ?thesis .
      qed
    } note scalar_to_sum = this
    {
      fix i j
      assume i: "i < n" and ij: "i > j"
      hence j: "j < n" by auto
      have "vec n (?v i) \<bullet> col (jordan_block n a) j = 0"
        unfolding scalar_to_sum[OF j] using ij i j by auto
    } note easy_case = this
    {
      fix i j
      assume j: "j < n" and ij: "i \<le> j"
      hence i: "i < n" and id: "\<And> p q. (if i \<le> j then p else q) = p" by auto
      have "vec n (?v i) \<bullet> col (jordan_block n a) j =
        (of_nat (r choose (j - i)) * (a ^ (Suc (r + i - j)))) +
          (if j = 0 then 0
         else if i \<le> j - 1 then of_nat (r choose (j - 1 - i)) * a ^ (r + i - (j - 1)) else 0)"
      unfolding scalar_to_sum[OF j]
      using ij by simp
      also have "\<dots> = of_nat (Suc r choose (j - i)) * a ^ (Suc (r + i) - j)"
      proof (cases j)
        case (Suc jj)
        {
          assume "i \<le> Suc jj" and "\<not> i \<le> jj"
          hence "i = Suc jj" by auto
          hence "a * a ^ (r + i - Suc jj) = a ^ (r + i - jj)" by simp
        }
        moreover
        {
          assume ijj: "i \<le> jj"
          have "of_nat (r choose (Suc jj - i)) * (a * a ^ (r + i - Suc jj))
          + of_nat (r choose (jj - i)) * a ^ (r + i - jj) =
            of_nat (Suc r choose (Suc jj - i)) * a ^ (r + i - jj)"
          proof (cases "r + i < jj")
            case True
            hence gt: "jj - i > r" "Suc jj - i > r" "Suc jj - i > Suc r" by auto
            show ?thesis
              unfolding binomial_eq_0[OF gt(1)] binomial_eq_0[OF gt(2)] binomial_eq_0[OF gt(3)]
              by simp
          next
            case False
            hence ge: "r + i \<ge> jj" by simp
            show ?thesis
            proof (cases "jj = r + i")
              case True
              have gt: "r < Suc r" by simp
              show ?thesis unfolding True by (simp add: binomial_eq_0[OF gt])
            next
              case False
              with ge have lt: "jj < r + i" by auto
              hence "r + i - jj = Suc (r + i - Suc jj)" by simp
              hence prod: "a * a ^ (r + i - Suc jj) = a ^ (r + i - jj)" by simp
              from ijj have id: "Suc jj - i = Suc (jj - i)" by simp
              have binom: "Suc r choose (Suc jj - i) =
                r choose (Suc jj - i) + (r choose (jj - i))"
                unfolding id
                by (subst binomial_Suc_Suc, simp)
              show ?thesis unfolding prod binom
                by (simp add: field_simps)
            qed
          qed
        }
        ultimately show ?thesis using ij unfolding Suc by auto
      qed auto
      finally have "vec n (?v i) \<bullet> col (jordan_block n a) j
        = of_nat (Suc r choose (j - i)) * a ^ (Suc (r + i) - j)" .
    } note main_case = this
    show ?thesis
      by (rule eq_matI, insert easy_case main_case, auto)
  qed
  finally show ?case by simp
qed

definition jordan_matrix :: "(nat \<times> 'a :: {zero,one})list \<Rightarrow> 'a mat" where
  "jordan_matrix n_as = diag_block_mat (map (\<lambda> (n,a). jordan_block n a) n_as)"

lemma jordan_matrix_dim[simp]:
  "dim_row (jordan_matrix n_as) = sum_list (map fst n_as)"
  "dim_col (jordan_matrix n_as) = sum_list (map fst n_as)"
  unfolding jordan_matrix_def
  by (subst dim_diag_block_mat, auto, (induct n_as, auto simp: Let_def)+)

lemma jordan_matrix_carrier[simp]:
  "jordan_matrix n_as \<in> carrier_mat (sum_list (map fst n_as)) (sum_list (map fst n_as))"
  unfolding carrier_mat_def by auto

lemma jordan_matrix_upper_triangular: "i < sum_list (map fst n_as)
  \<Longrightarrow> j < i \<Longrightarrow> jordan_matrix n_as $$ (i,j) = 0"
  unfolding jordan_matrix_def
  by (rule diag_block_upper_triangular, auto simp: jordan_matrix_def[symmetric])

lemma jordan_matrix_pow: "(jordan_matrix n_as) ^\<^sub>m r =
  diag_block_mat (map (\<lambda> (n,a). (jordan_block n a) ^\<^sub>m r) n_as)"
  unfolding jordan_matrix_def
  by (subst diag_block_pow_mat, force, rule arg_cong[of _ _ diag_block_mat], auto)

lemma jordan_matrix_char_poly:
  "char_poly (jordan_matrix n_as) = (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)"
proof -
  let ?n = "sum_list (map fst n_as)"
  have "diag_mat
     ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m (sum_list (map fst n_as)) + map_mat (\<lambda>a. [:- a:]) (jordan_matrix n_as)) =
    concat (map (\<lambda>(n, a). replicate n [:- a, 1:]) n_as)" unfolding jordan_matrix_def
  proof (induct n_as)
    case (Cons na n_as)
    obtain n a where na: "na = (n,a)" by force
    let ?n2 = "sum_list (map fst n_as)"
    note fbo = four_block_one_mat
    note mz = zero_carrier_mat
    note mo = one_carrier_mat
    have mA: "\<And> A. A \<in> carrier_mat (dim_row A) (dim_col A)" unfolding carrier_mat_def by auto
    let ?Bs = "map (\<lambda>(x, y). jordan_block x y) n_as"
    let ?B = "diag_block_mat ?Bs"
    from jordan_matrix_dim[of n_as, unfolded jordan_matrix_def]
    have dimB: "dim_row ?B = ?n2" "dim_col ?B = ?n2" by auto
    hence B: "?B \<in> carrier_mat ?n2 ?n2" unfolding carrier_mat_def by simp
    show ?case unfolding na fbo
    apply (simp add: Let_def fbo[symmetric] del: fbo)
    apply (subst smult_four_block_mat[OF mo mz mz mo])
    apply (subst map_four_block_mat[OF jordan_block_carrier mz mz mA])
    apply (subst add_four_block_mat[of _ n n _ ?n2 _ ?n2], auto simp: dimB B)
    apply (subst diag_four_block_mat[of _ n _ ?n2], auto simp: dimB B)
    apply (subst Cons, auto simp: jordan_block_def diag_mat_def,
      intro nth_equalityI, auto)
    done
  qed (force simp: diag_mat_def)
  also have "prod_list ... = (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)"
    by (induct n_as, auto)
  finally
  show ?thesis unfolding char_poly_defs
    by (subst det_upper_triangular[of _ ?n], auto simp: jordan_matrix_upper_triangular)
qed

definition jordan_nf :: "'a :: semiring_1 mat \<Rightarrow> (nat \<times> 'a)list \<Rightarrow> bool" where
  "jordan_nf A n_as \<equiv> (0 \<notin> fst ` set n_as \<and> similar_mat A (jordan_matrix n_as))"

lemma jordan_nf_powE: assumes A: "A \<in> carrier_mat n n" and jnf: "jordan_nf A n_as"
  obtains P Q where "P \<in> carrier_mat n n" "Q \<in> carrier_mat n n" and
  "char_poly A = (\<Prod>(na, a)\<leftarrow>n_as. [:- a, 1:] ^ na)"
  "\<And> k. A ^\<^sub>m k = P * (jordan_matrix n_as)^\<^sub>m k * Q"
proof -
  from A have dim: "dim_row A = n" by auto
  assume obt: "\<And>P Q. P \<in> carrier_mat n n \<Longrightarrow> Q \<in> carrier_mat n n \<Longrightarrow>
    char_poly A = (\<Prod>(na, a)\<leftarrow>n_as. [:- a, 1:] ^ na) \<Longrightarrow>
    (\<And>k. A ^\<^sub>m k = P * jordan_matrix n_as ^\<^sub>m k * Q) \<Longrightarrow> thesis"
  from jnf[unfolded jordan_nf_def] obtain P Q where
    simw: "similar_mat_wit A (jordan_matrix n_as) P Q"
    and sim: "similar_mat A (jordan_matrix n_as)" unfolding similar_mat_def by blast
  show thesis
  proof (rule obt)
    show "\<And> k. A ^\<^sub>m k = P * jordan_matrix n_as ^\<^sub>m k * Q"
      by (rule similar_mat_wit_pow_id[OF simw])
    show "char_poly A = (\<Prod>(na, a)\<leftarrow>n_as. [:- a, 1:] ^ na)"
      unfolding char_poly_similar[OF sim] jordan_matrix_char_poly ..
  qed (insert simw[unfolded similar_mat_wit_def Let_def dim], auto)
qed

lemma choose_poly_bound: assumes "i \<le> d"
  shows "r choose i \<le> max 1 (r^d)"
proof (cases "i \<le> r")
  case False
  hence "r choose i = 0" by simp
  thus ?thesis by arith
next
  case True
  show ?thesis
  proof (cases r)
    case (Suc rr)
    from binomial_le_pow[OF True] have "r choose i \<le> r ^ i" by simp
    also have "\<dots> \<le> r^d" using power_increasing[OF \<open>i \<le> d\<close>, of r] Suc by auto
    finally show ?thesis by simp
  qed (insert True, simp)
qed

context
  fixes b :: "'a :: archimedean_field"
  assumes b: "0 < b" "b < 1"
begin

lemma poly_exp_constant_bound: "\<exists> p. \<forall> x. c * b ^ x * of_nat x ^ deg \<le> p"
proof (cases "c \<le> 0")
  case True
  show ?thesis
    by (rule exI[of _ 0], intro allI,
    rule mult_nonpos_nonneg[OF mult_nonpos_nonneg[OF True]], insert b, auto)
next
  case False
  hence c: "c \<ge> 0" by simp
  from poly_exp_bound[OF b, of deg] obtain p where "\<And> x. b ^ x * of_nat x ^ deg \<le> p" by auto
  from mult_left_mono[OF this c]
  show ?thesis by (intro exI[of _ "c * p"], auto simp: ac_simps)
qed

lemma poly_exp_max_constant_bound: "\<exists> p. \<forall> x. c * b ^ x * max 1 (of_nat x ^ deg) \<le> p"
proof -
  from poly_exp_constant_bound[of c deg] obtain p where
    p: "\<And> x. c * b ^ x * of_nat x ^ deg \<le> p" by auto
  show ?thesis
  proof (rule exI[of _ "max p c"], intro allI)
    fix x
    let ?exp = "of_nat x ^ deg :: 'a"
    show "c * b ^ x * max 1 ?exp \<le> max p c"
    proof (cases "x = 0")
      case False
      hence "?exp \<noteq> of_nat 0" by simp
      hence "?exp \<ge> 1" by (metis less_one not_less of_nat_1 of_nat_less_iff of_nat_power)
      hence "max 1 ?exp = ?exp" by simp
      thus ?thesis using p[of x] by simp
    qed (cases deg, auto)
  qed
qed
end

context
  fixes a :: "'a :: real_normed_field"
begin
lemma jordan_block_bound:
  assumes i: "i < n" and j: "j < n"
  shows "norm ((jordan_block n a ^\<^sub>m k) $$ (i,j))
    \<le> norm a ^ (k + i - j) * max 1 (of_nat k ^ (n - 1))"
    (is "?lhs \<le> ?rhs")
proof -
  have id: "(jordan_block n a ^\<^sub>m k) $$ (i,j) = (if i \<le> j then of_nat (k choose (j - i)) * a ^ (k + i - j) else 0)"
    unfolding jordan_block_pow using i j by auto
  from i j have diff: "j - i \<le> n - 1" by auto
  show ?thesis
  proof (cases "i \<le> j")
    case False
    thus ?thesis unfolding id by simp
  next
    case True
    hence "?lhs = norm (of_nat (k choose (j - i)) * a ^ (k + i - j))" unfolding id by simp
    also have "\<dots> \<le> norm (of_nat (k choose (j - i)) :: 'a) * norm (a ^ (k + i - j))"
      by (rule norm_mult_ineq)
    also have "\<dots> \<le> (max 1 (of_nat k ^ (n - 1))) * norm a ^ (k + i - j)"
    proof (rule mult_mono[OF _ norm_power_ineq _ norm_ge_zero])
      have "k choose (j - i) \<le> max 1 (k ^ (n - 1))"
        by (rule choose_poly_bound[OF diff])
      hence "norm (of_nat (k choose (j - i)) :: 'a) \<le> of_nat (max 1 (k ^ (n - 1)))"
        unfolding norm_of_nat of_nat_le_iff .
      also have "\<dots> = max 1 (of_nat k ^ (n - 1))" by (metis max_def of_nat_1 of_nat_le_iff of_nat_power)
      finally show "norm (of_nat (k choose (j - i)) :: 'a) \<le> max 1 (real_of_nat k ^ (n - 1))" .
    qed simp
    also have "\<dots> = ?rhs" by simp
    finally show ?thesis .
  qed
qed

lemma jordan_block_poly_bound:
  assumes i: "i < n" and j: "j < n" and a: "norm a = 1"
  shows "norm ((jordan_block n a ^\<^sub>m k) $$ (i,j)) \<le> max 1 (of_nat k ^ (n - 1))"
    (is "?lhs \<le> ?rhs")
proof -
  from jordan_block_bound[OF i j, of k, unfolded a]
  show ?thesis by simp
qed

theorem jordan_block_constant_bound: assumes a: "norm a < 1"
  shows "\<exists> p. \<forall> i j k. i < n \<longrightarrow> j < n \<longrightarrow> norm ((jordan_block n a ^\<^sub>m k) $$ (i,j)) \<le> p"
proof (cases "a = 0")
  case True
  show ?thesis
  proof (rule exI[of _ 1], intro allI impI)
    fix i j k
    assume *: "i < n" "j < n"
    {
      assume ij: "i \<le> j"
      have "norm ((of_nat (k choose (j - i)) :: 'a) * 0 ^ (k + i - j)) \<le> 1" (is "norm ?lhs \<le> 1")
      proof (cases "k + i > j")
        case True
        hence "?lhs = 0" by simp
        also have "norm (\<dots>) \<le> 1" by simp
        finally show ?thesis .
      next
        case False
        hence id: "?lhs = (of_nat (k choose (j - i)) :: 'a)" and j: "j - i \<ge> k" by auto
        from j have "k choose (j - i) = 0 \<or> k choose (j - i) = 1" by (simp add: nat_less_le)
        thus "norm ?lhs \<le> 1"
        proof
          assume k: "k choose (j - i) = 0"
          show ?thesis unfolding id k by simp
        next
          assume k: "k choose (j - i) = 1"
          show ?thesis unfolding id unfolding k by simp
        qed
      qed
    }
    thus "norm ((jordan_block n a ^\<^sub>m k) $$ (i,j)) \<le> 1" unfolding True
      unfolding jordan_block_pow using * by auto
  qed
next
  case False
  hence na: "norm a > 0" by auto
  define c where "c = inverse (norm a ^ n)"
  define deg where "deg = n - 1"
  have c: "c > 0" unfolding c_def using na by auto
  define b where "b = norm a"
  from a na have "0 < b" "b < 1" unfolding b_def by auto
  from poly_exp_max_constant_bound[OF this, of c deg]
  obtain p where "\<And> k. c * b ^ k * max 1 (of_nat k ^ deg) \<le> p" by auto
  show ?thesis
  proof (intro exI[of _ p], intro allI impI)
    fix i j k
    assume ij: "i < n" "j < n"
    from jordan_block_bound[OF this]
    have "norm ((jordan_block n a ^\<^sub>m k) $$ (i, j))
      \<le> norm a ^ (k + i - j) * max 1 (real_of_nat k ^ (n - 1))" .
    also have "\<dots> \<le> c * norm a ^ k * max 1 (real_of_nat k ^ (n - 1))"
    proof (rule mult_right_mono)
      from ij have "i - j \<le> n" by auto
      show "norm a ^ (k + i - j) \<le> c * norm a ^ k"
      proof (rule mult_left_le_imp_le)
        show "0 < norm a ^ n" using na by auto
        let ?lhs = "norm a ^ n * norm a ^ (k + i - j)"
        let ?rhs = "norm a ^ n * (c * norm a ^ k)"
        from ij have ge: "n + (k + i - j) \<ge> k" by arith
        have "?lhs = norm a ^ (n + (k + i - j))" by (simp add: power_add)
        also have "\<dots> \<le> norm a ^ k" using ge a na using less_imp_le power_decreasing by blast
        also have "\<dots> = ?rhs" unfolding c_def using na by simp
        finally show "?lhs \<le> ?rhs" .
      qed
    qed simp
    also have "\<dots> = c * b ^ k * max 1 (real_of_nat k ^ deg)" unfolding b_def deg_def ..
    also have "\<dots> \<le> p" by fact
    finally show "norm ((jordan_block n a ^\<^sub>m k) $$ (i, j)) \<le> p" .
  qed
qed

definition norm_bound :: "'a mat \<Rightarrow> real \<Rightarrow> bool" where
  "norm_bound A b \<equiv> \<forall> i j. i < dim_row A \<longrightarrow> j < dim_col A \<longrightarrow> norm (A $$ (i,j)) \<le> b"

lemma norm_boundI[intro]:
  assumes "\<And> i j. i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> norm (A $$ (i,j)) \<le> b"
  shows "norm_bound A b"
  unfolding norm_bound_def using assms by blast

lemma  jordan_block_constant_bound2:
"\<exists>p. norm (a :: 'a :: real_normed_field) < 1 \<longrightarrow>
    (\<forall>i j k. i < n \<longrightarrow> j < n \<longrightarrow> norm ((jordan_block n a ^\<^sub>m k) $$ (i, j)) \<le> p)"
using jordan_block_constant_bound by auto

lemma jordan_matrix_poly_bound2:
  fixes n_as :: "(nat \<times> 'a) list"
  assumes n_as: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> n > 0 \<Longrightarrow> norm a \<le> 1"
  and N: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> norm a = 1 \<Longrightarrow> n \<le> N"
  shows "\<exists>c1. \<forall>k. \<forall>e \<in> elements_mat (jordan_matrix n_as ^\<^sub>m k).
    norm e \<le> c1 + of_nat k ^ (N - 1)"
proof -
  from jordan_matrix_carrier[of n_as] obtain d where
    jm: "jordan_matrix n_as \<in> carrier_mat d d" by blast
  define f where "f = (\<lambda>n (a::'a) i j k. norm ((jordan_block n a ^\<^sub>m k) $$ (i,j)))"
  let ?g = "\<lambda>k c1. c1 + of_nat k ^ (N-1)"
  let ?P = "\<lambda>n (a::'a) i j k c1. f n a i j k \<le> ?g k c1"
  define Q where "Q = (\<lambda>n (a::'a) k c1. \<forall>i j. i<n \<longrightarrow> j<n \<longrightarrow> ?P n a i j k c1)"
  have "\<And> c c' k n a i j. c \<le> c' \<Longrightarrow> ?P n a i j k c \<Longrightarrow> ?P n a i j k c'" by auto
  hence Q_mono: "\<And>n a c c'. c \<le> c' \<Longrightarrow> \<forall>k. Q n a k c \<Longrightarrow> \<forall>k. Q n a k c'"
    unfolding Q_def by arith
  { fix n a assume na: "(n,a) \<in> set n_as"
    obtain c where c: "norm a < 1 \<longrightarrow> (\<forall>i j k. i < n \<longrightarrow> j < n \<longrightarrow> f n a i j k \<le> c)"
      apply (rule exE[OF jordan_block_constant_bound2])
      unfolding f_def using Jordan_Normal_Form.jordan_block_constant_bound2
      by metis
    define c1 where "c1 = max 1 c"
    then have "c1 \<ge> 1" "c1 \<ge> c" by auto
    have "\<exists>c1. \<forall>k i j. i < n \<longrightarrow> j < n \<longrightarrow> ?P n a i j k c1"
    proof rule+
      fix i j k assume "i < n" "j < n"
      then have "0<n" by auto
      let ?jbs = "map (\<lambda>(n,a). jordan_block n a) n_as"
      have sq_jbs: "Ball (set ?jbs) square_mat" by auto
      have "jordan_matrix n_as ^\<^sub>m k = diag_block_mat (map (\<lambda>A. A ^\<^sub>m k) ?jbs)"
        unfolding jordan_matrix_def using diag_block_pow_mat[OF sq_jbs] by auto
      show "?P n a i j k c1"
      proof (cases "norm a = 1")
        case True {
          have nN:"n-1 \<le> N-1" using N[OF na] True by auto
          have "f n a i j k \<le> max 1 (of_nat k ^ (n-1))"
            using Jordan_Normal_Form.jordan_block_poly_bound True \<open>i<n\<close> \<open>j<n\<close>
            unfolding f_def by auto
          also have "... \<le> max 1 (of_nat k ^ (N-1))"
            proof (cases "k=0")
              case False then show ?thesis
                by (subst max.mono[OF _ power_increasing[OF nN]], auto)
            qed (simp add: power_eq_if)
          also have "... \<le> max c1 (of_nat k ^ (N-1))" using \<open>c1\<ge>1\<close> by auto
          also have "... \<le> c1 + (of_nat k ^ (N-1))" using \<open>c1\<ge>1\<close> by auto
          finally show ?thesis by simp
        } next
        case False {
          then have na1: "norm a < 1" using n_as[OF na] \<open>0<n\<close> by auto
          hence "f n a i j k \<le> c" using c \<open>i<n\<close> \<open>j<n\<close> by auto
          also have "... \<le> c1" using \<open>c\<le>c1\<close>.
          also have "... \<le> c1 + of_nat k ^ (N-1)" by auto
          finally show ?thesis by auto
        }
      qed
    qed
  }
  hence "\<forall>na. \<exists>c1. na \<in> set n_as \<longrightarrow> (\<forall>k. Q (fst na) (snd na) k c1)"
    unfolding Q_def by auto
  from choice[OF this] obtain c'
    where c': "\<And> na k. na \<in> set n_as \<Longrightarrow> Q (fst na) (snd na) k (c' na)" by blast
  define c where "c = max 0 (Max (set (map c' n_as)))"
  { fix n a assume na: "(n,a) \<in> set n_as"
    then have Q: "\<forall> k. Q n a k (c' (n,a))" using c'[OF na] by auto
    from na have "c' (n,a) \<in> set (map c' n_as)" by auto
    from Max_ge[OF _ this] have "c' (n,a) \<le> c" unfolding c_def by auto
    from Q_mono[OF this Q] have "\<And> k. Q n a k c" by blast
  }
  hence Q: "\<And>k n a. (n,a) \<in> set n_as \<Longrightarrow> Q n a k c" by auto
  have c0: "c \<ge> 0" unfolding c_def by simp
  { fix k n a e
    assume na:"(n,a) \<in> set n_as"
    let ?jbk = "jordan_block n a ^\<^sub>m k"
    assume "e \<in> elements_mat ?jbk"
    from elements_matD[OF this] obtain i j
      where "i < n" "j < n" and [simp]: "e = ?jbk $$ (i,j)"
      by (simp only:pow_mat_dim_square[OF jordan_block_carrier],auto)
    hence "norm e \<le> ?g k c" using Q[OF na] unfolding Q_def f_def by simp
  }
  hence norm_jordan:
    "\<And>k. \<forall>(n,a) \<in> set n_as. \<forall>e \<in> elements_mat (jordan_block n a ^\<^sub>m k).
     norm e \<le> ?g k c" by auto
  { fix k
    let ?jmk = "jordan_matrix n_as ^\<^sub>m k"
    have "dim_row ?jmk = d" "dim_col ?jmk = d"
      using jm by (simp only:pow_mat_dim_square[OF jm])+
    let ?As = "(map (\<lambda>(n,a). jordan_block n a ^\<^sub>m k) n_as)"
    have "\<And>e. e \<in> elements_mat ?jmk \<Longrightarrow> norm e \<le> ?g k c"
    proof -
      fix e assume e:"e \<in> elements_mat ?jmk"
      obtain i j where ij: "i < d" "j < d" and "e = ?jmk $$ (i,j)"
        using elements_matD[OF e] by (simp only:pow_mat_dim_square[OF jm],auto)
      have "?jmk = diag_block_mat ?As"
        using jordan_matrix_pow[of n_as k] by auto
      hence "elements_mat ?jmk \<subseteq> {0} \<union> \<Union> (set (map elements_mat ?As))"
        using elements_diag_block_mat[of ?As] by auto
      hence e_mem: "e \<in> {0} \<union> \<Union> (set (map elements_mat ?As))"
        using e by blast
      show "norm e \<le> ?g k c"
      proof (cases "e = 0")
        case False
          then have "e \<in> \<Union> (set (map elements_mat ?As))" using e_mem by auto
          then obtain n a
            where "e \<in> elements_mat (jordan_block n a ^\<^sub>m k)"
            and na: "(n,a) \<in> set n_as" by force
          thus ?thesis using norm_jordan na by force
      qed (insert c0, auto)
    qed
  }
  thus ?thesis by auto
qed

lemma norm_bound_bridge:
  "\<forall>e \<in> elements_mat A. norm e \<le> b \<Longrightarrow> norm_bound A b"
  unfolding norm_bound_def by force

lemma norm_bound_mult: assumes A1: "A1 \<in> carrier_mat nr n"
  and A2: "A2 \<in> carrier_mat n nc"
  and b1: "norm_bound A1 b1"
  and b2: "norm_bound A2 b2"
  shows "norm_bound (A1 * A2) (b1 * b2 * of_nat n)"
proof
  let ?A = "A1 * A2"
  let ?n = "of_nat n"
  fix i j
  assume i: "i < dim_row ?A" and j: "j < dim_col ?A"
  define v1 where "v1 = (\<lambda> k. row A1 i $ k)"
  define v2 where "v2 = (\<lambda> k. col A2 j $ k)"
  from assms(1-2) have dim: "dim_row A1 = nr" "dim_col A2 = nc" "dim_col A1 = n" "dim_row A2 = n" by auto
  {
    fix k
    assume k: "k < n"
    have n: "norm (v1 k) \<le> b1" "norm (v2 k) \<le> b2"
      using i j k dim v1_def v2_def
      b1[unfolded norm_bound_def, rule_format, of i k]
      b2[unfolded norm_bound_def, rule_format, of k j] by auto
    have "norm (v1 k * v2 k) \<le> norm (v1 k) * norm (v2 k)" by (rule norm_mult_ineq)
    also have "\<dots> \<le> b1 * b2" by (rule mult_mono'[OF n], auto)
    finally have "norm (v1 k * v2 k) \<le> b1 * b2" .
  } note bound = this
  have "?A $$ (i,j) = row A1 i \<bullet> col A2 j" using dim i j by simp
  also have "\<dots> = (\<Sum> k = 0 ..< n. v1 k * v2 k)" unfolding scalar_prod_def
    using dim i j v1_def v2_def by simp
  also have "norm (\<dots>) \<le> (\<Sum> k = 0 ..< n. b1 * b2)"
    by (rule sum_norm_le, insert bound, simp)
  also have "\<dots> = b1 * b2 * ?n" by simp
  finally show "norm (?A $$ (i,j)) \<le> b1 * b2 * ?n" .
qed

lemma norm_bound_max: "norm_bound A (Max {norm (A $$ (i,j)) | i j. i < dim_row A \<and> j < dim_col A})"
  (is "norm_bound A (Max ?norms)")
proof
  fix i j
  have fin: "finite ?norms" by (simp add: finite_image_set2)
  assume "i < dim_row A" and "j < dim_col A"
  hence "norm (A $$ (i,j)) \<in> ?norms" by auto
  from Max_ge[OF fin this] show "norm (A $$ (i,j)) \<le> Max ?norms" .
qed

lemma jordan_matrix_poly_bound: fixes n_as :: "(nat \<times> 'a)list"
  assumes n_as: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> n > 0 \<Longrightarrow> norm a \<le> 1"
  and N: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> norm a = 1 \<Longrightarrow> n \<le> N"
  shows "\<exists> c1. \<forall> k. norm_bound (jordan_matrix n_as ^\<^sub>m k) (c1 + of_nat k ^ (N - 1))"
  using jordan_matrix_poly_bound2 norm_bound_bridge N n_as
  by metis

lemma jordan_nf_matrix_poly_bound: fixes n_as :: "(nat \<times> 'a)list"
  assumes A: "A \<in> carrier_mat n n"
  and n_as: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> n > 0 \<Longrightarrow> norm a \<le> 1"
  and N: "\<And> n a. (n,a) \<in> set n_as \<Longrightarrow> norm a = 1 \<Longrightarrow> n \<le> N"
  and jnf: "jordan_nf A n_as"
  shows "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (N - 1))"
proof -
  let ?cp2 = "\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n"
  let ?J = "jordan_matrix n_as"
  from jnf[unfolded jordan_nf_def]
  have sim: "similar_mat A ?J" by auto
  then obtain P Q where sim_wit: "similar_mat_wit A ?J P Q" unfolding similar_mat_def by auto
  from similar_mat_wit_pow_id[OF this] have pow: "\<And> k. A ^\<^sub>m k = P * ?J ^\<^sub>m k * Q" .
  from sim_wit[unfolded similar_mat_wit_def Let_def] A
  have J: "?J \<in> carrier_mat n n" and P: "P \<in> carrier_mat n n" and Q: "Q \<in> carrier_mat n n"
    unfolding carrier_mat_def by force+
  have "\<exists>c1. \<forall> k. norm_bound (?J ^\<^sub>m k) (c1 + of_nat k ^ (N - 1))"
    by (rule jordan_matrix_poly_bound[OF n_as N])
  then obtain c1 where
    bound_pow: "\<And> k. norm_bound ((?J ^\<^sub>m k)) (c1 + of_nat k ^ (N - 1))" by blast
  obtain bP where bP: "norm_bound P bP" using norm_bound_max[of P] by auto
  obtain bQ where bQ: "norm_bound Q bQ" using norm_bound_max[of Q] by auto
  let ?n = "of_nat n :: real"
  let ?c2 = "bP * ?n * bQ * ?n"
  let ?c1 = "?c2 * c1"
  {
    fix k
    have Jk: "?J ^\<^sub>m k \<in> carrier_mat n n" using J by simp
    from norm_bound_mult[OF mult_carrier_mat[OF P Jk] Q
      norm_bound_mult[OF P Jk bP bound_pow] bQ, folded pow]
    have "norm_bound (A ^\<^sub>m k) (?c1 + ?c2 * of_nat k ^ (N - 1))"  (is "norm_bound _ ?exp")
      by (simp add: field_simps)
  } note main = this
  show ?thesis
    by (intro exI allI, rule main)
qed
end

context
  fixes f_ty :: "'a :: field itself"
begin
lemma char_matrix_jordan_block: "char_matrix (jordan_block n a) b = (jordan_block n (a - b))"
  unfolding char_matrix_def jordan_block_def by auto

lemma diag_jordan_block_pow: "diag_mat (jordan_block n (a :: 'a) ^\<^sub>m k) = replicate n (a ^ k)"
  unfolding diag_mat_def jordan_block_pow
  by (intro nth_equalityI, auto)

lemma jordan_block_zero_pow: "(jordan_block n (0 :: 'a)) ^\<^sub>m k =
  (mat n n (\<lambda> (i,j). if j \<ge> i \<and> j - i = k then 1 else 0))"
proof -
  {
    fix i j
    assume  *: "j - i \<noteq> k"
    have "of_nat (k choose (j - i)) * 0 ^ (k + i - j) = (0 :: 'a)"
    proof (cases "k + i - j > 0")
      case True thus ?thesis by (cases "k + i - j", auto)
    next
      case False
      with * have "j - i > k" by auto
      thus ?thesis by (simp add: binomial_eq_0)
    qed
  }
  thus ?thesis unfolding jordan_block_pow by (intro eq_matI, auto)
qed
end

lemma jordan_matrix_concat_diag_block_mat: "jordan_matrix (concat jbs) = diag_block_mat (map jordan_matrix jbs)"
  unfolding jordan_matrix_def[abs_def]
  by (induct jbs, auto simp: diag_block_mat_append Let_def)

lemma jordan_nf_diag_block_mat: assumes Ms: "\<And> A jbs. (A,jbs) \<in> set Ms \<Longrightarrow> jordan_nf A jbs"
  shows "jordan_nf (diag_block_mat (map fst Ms)) (concat (map snd Ms))"
proof -
  let ?Ms = "map (\<lambda> (A, jbs). (A, jordan_matrix jbs)) Ms"
  have id: "map fst ?Ms = map fst Ms" by auto
  have id2: "map snd ?Ms = map jordan_matrix (map snd Ms)" by auto
  {
    fix A B
    assume "(A,B) \<in> set ?Ms"
    then obtain jbs where mem: "(A,jbs) \<in> set Ms" and B: "B = jordan_matrix jbs" by auto
    from Ms[OF mem] have "similar_mat A B" unfolding B jordan_nf_def by auto
  }
  from similar_diag_mat_block_mat[of ?Ms, OF this, unfolded id id2] Ms
  show ?thesis
    unfolding jordan_nf_def jordan_matrix_concat_diag_block_mat by force
qed

lemma jordan_nf_char_poly: assumes "jordan_nf A n_as"
  shows "char_poly A = (\<Prod> (n,a) \<leftarrow> n_as. [:- a, 1:] ^ n)"
  unfolding jordan_matrix_char_poly[symmetric]
  by (rule char_poly_similar, insert assms[unfolded jordan_nf_def], auto)

lemma jordan_nf_block_size_order_bound: assumes jnf: "jordan_nf A n_as"
  and mem: "(n,a) \<in> set n_as"
  shows "n \<le> order a (char_poly A)"
proof -
  from jnf[unfolded jordan_nf_def]
  have "similar_mat A (jordan_matrix n_as)" by auto
  from similar_matD[OF this] obtain m where "A \<in> carrier_mat m m" by auto
  from degree_monic_char_poly[OF this] have A: "char_poly A \<noteq> 0" by auto
  from mem obtain as bs where nas: "n_as = as @ (n,a) # bs"
    by (meson split_list)
  from jordan_nf_char_poly[OF jnf]
  have cA: "char_poly A = (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)" .
  also have "\<dots> = [: -a, 1:] ^ n * (\<Prod>(n, a)\<leftarrow> as @ bs. [:- a, 1:] ^ n)" unfolding nas by auto
  also have "[: -a,1 :] ^ n dvd \<dots>" unfolding dvd_def by blast
  finally have "[: -a,1 :] ^ n dvd char_poly A" by auto
  from order_max[OF this A] show ?thesis .
qed

lemma similar_mat_jordan_block_smult: fixes A :: "'a :: field mat"
  assumes "similar_mat A (jordan_block n a)"
   and k: "k \<noteq> 0"
  shows "similar_mat (k \<cdot>\<^sub>m A) (jordan_block n (k * a))"
proof -
  let ?J = "jordan_block n a"
  let ?Jk = "jordan_block n (k * a)"
  let ?kJ = "k \<cdot>\<^sub>m jordan_block n a"
  from k have inv: "k ^ i \<noteq> 0" for i by auto
  let ?A = "mat_diag n (\<lambda> i. k^i)"
  let ?B = "mat_diag n (\<lambda> i. inverse (k^i))"
  have "similar_mat_wit ?Jk ?kJ ?A ?B"
  proof (rule similar_mat_witI)
    show "jordan_block n (k * a) = ?A * ?kJ * ?B"
      by (subst mat_diag_mult_left[of _ _ n], force, subst mat_diag_mult_right[of _ n],
       insert k inv, auto simp: jordan_block_def field_simps intro!: eq_matI)
  qed (auto simp: inv field_simps k)
  hence kJ: "similar_mat ?Jk ?kJ"
    unfolding similar_mat_def by auto
  have "similar_mat A ?J" by fact
  hence "similar_mat (k \<cdot>\<^sub>m A) (k \<cdot>\<^sub>m ?J)" by (rule similar_mat_smult)
  with kJ show ?thesis
    using similar_mat_sym similar_mat_trans by blast
qed

lemma jordan_matrix_Cons:  "jordan_matrix (Cons (n,a) n_as) = four_block_mat
  (jordan_block n a)                 (0\<^sub>m n (sum_list (map fst n_as)))
  (0\<^sub>m (sum_list (map fst n_as)) n)   (jordan_matrix n_as)"
  unfolding jordan_matrix_def by (simp, simp add: jordan_matrix_def[symmetric])

lemma similar_mat_jordan_matrix_smult:  fixes n_as :: "(nat \<times> 'a :: field) list"
  assumes k: "k \<noteq> 0"
  shows "similar_mat (k \<cdot>\<^sub>m jordan_matrix n_as) (jordan_matrix (map (\<lambda> (n,a). (n, k * a)) n_as))"
proof (induct n_as)
  case Nil
  show ?case by (auto simp: jordan_matrix_def intro!: similar_mat_refl)
next
  case (Cons na n_as)
  obtain n a where na: "na = (n,a)" by force
  let ?l = "map (\<lambda> (n,a). (n, k * a))"
  let ?n = "sum_list (map fst n_as)"
  have "k \<cdot>\<^sub>m jordan_matrix (Cons na n_as) = k \<cdot>\<^sub>m four_block_mat
     (jordan_block n a) (0\<^sub>m n ?n)
     (0\<^sub>m ?n n) (jordan_matrix n_as)" (is "?M = _ \<cdot>\<^sub>m four_block_mat ?A ?B ?C ?D")
    by (simp add: na jordan_matrix_Cons)
  also have "\<dots> = four_block_mat (k \<cdot>\<^sub>m ?A) ?B ?C (k \<cdot>\<^sub>m ?D)"
    by (subst smult_four_block_mat, auto)
  finally have jm: "?M = four_block_mat (k \<cdot>\<^sub>m ?A) ?B ?C (k \<cdot>\<^sub>m ?D)" .
  have [simp]: "fst (case x of (n :: nat, a) \<Rightarrow> (n, k * a)) = fst x" for x by (cases x, auto)
  have jmk: "jordan_matrix (?l (Cons na n_as)) = four_block_mat
     (jordan_block n (k * a)) ?B
     ?C (jordan_matrix (?l n_as))" (is "?kM = four_block_mat ?kA _ _ ?kD")
    by (simp add: na jordan_matrix_Cons o_def)
  show ?case unfolding jmk jm
    by (rule similar_mat_four_block_0_0[OF similar_mat_jordan_block_smult[OF _ k] Cons],
      auto intro!: similar_mat_refl)
qed

lemma jordan_nf_smult: fixes k :: "'a :: field"
  assumes jn: "jordan_nf A n_as"
  and k: "k \<noteq> 0"
  shows "jordan_nf (k \<cdot>\<^sub>m A) (map (\<lambda> (n,a). (n, k * a)) n_as)"
proof -
  let ?l = "map (\<lambda> (n,a). (n, k * a))"
  from jn[unfolded jordan_nf_def] have sim: "similar_mat A (jordan_matrix n_as)" by auto
  from similar_mat_smult[OF this, of k] similar_mat_jordan_matrix_smult[OF k, of n_as]
  have "similar_mat (k \<cdot>\<^sub>m A) (jordan_matrix (map (\<lambda>(n, a). (n, k * a)) n_as))"
    using similar_mat_trans by blast
  with jn show ?thesis unfolding jordan_nf_def by force
qed

lemma jordan_nf_order: assumes "jordan_nf A n_as"
  shows "order a (char_poly A)  = sum_list (map fst (filter (\<lambda> na. snd na = a) n_as))"
proof -
  let ?p = "\<lambda> n_as. (\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n)"
  let ?s = "\<lambda> n_as. sum_list (map fst (filter (\<lambda> na. snd na = a) n_as))"
  from jordan_nf_char_poly[OF assms]
  have "order a (char_poly A) = order a (?p n_as)" by simp
  also have "\<dots> = ?s n_as"
  proof (induct n_as)
    case (Cons nb n_as)
    obtain n b where nb: "nb = (n,b)" by force
    have "order a (?p (nb # n_as)) = order a ([: -b, 1:] ^ n * ?p n_as)" unfolding nb by simp
    also have "\<dots> = order a ([: -b, 1:] ^ n) + order a (?p n_as)"
      by (rule order_mult, auto simp: prod_list_zero_iff)
    also have "\<dots> = (if a = b then n else 0) + ?s n_as" unfolding Cons order_linear_power by simp
    also have "\<dots> = ?s (nb # n_as)" unfolding nb by auto
    finally show ?case .
  qed simp
  finally show ?thesis .
qed

subsection \<open>Application for Complexity\<close>

lemma factored_char_poly_norm_bound: assumes A: "A \<in> carrier_mat n n"
  and linear_factors: "char_poly A = (\<Prod> (a :: 'a :: real_normed_field) \<leftarrow> as. [:- a, 1:])"
  and jnf_exists: "\<exists> n_as. jordan_nf A n_as"
  and le_1: "\<And> a. a \<in> set as \<Longrightarrow> norm a \<le> 1"
  and le_N: "\<And> a. a \<in> set as \<Longrightarrow> norm a = 1 \<Longrightarrow> length (filter ((=) a) as) \<le> N"
  shows "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (N - 1))"
proof -
  from jnf_exists obtain n_as
    where jnf: "jordan_nf A n_as" by auto
  let ?cp1 = "(\<Prod> a \<leftarrow> as. [:- a, 1:])"
  let ?cp2 = "\<Prod>(n, a)\<leftarrow>n_as. [:- a, 1:] ^ n"
  let ?J = "jordan_matrix n_as"
  from jnf[unfolded jordan_nf_def]
  have sim: "similar_mat A ?J" by auto
  from char_poly_similar[OF sim, unfolded linear_factors jordan_matrix_char_poly]
  have cp: "?cp1 = ?cp2" .
  show ?thesis
  proof (rule jordan_nf_matrix_poly_bound[OF A _ _ jnf])
    fix n a
    assume na: "(n,a) \<in> set n_as"
    then obtain na1 na2 where n_as: "n_as = na1 @ (n,a) # na2"
      unfolding in_set_conv_decomp by auto
    then obtain p where "?cp2 = [: -a, 1 :]^n * p" unfolding n_as by auto
    from cp[unfolded this] have dvd: "[: -a, 1 :] ^ n dvd ?cp1" by auto
    let ?as = "filter ((=) a) as"
    let ?pn = "\<lambda> as. \<Prod>a\<leftarrow>as. [:- a, 1:]"
    let ?p = "\<lambda> as. \<Prod>a\<leftarrow>as. [: a, 1:]"
    have "?pn as = ?p (map uminus as)" by (induct as, auto)
    from poly_linear_exp_linear_factors[OF dvd[unfolded this]]
    have "n \<le> length (filter ((=) (- a)) (map uminus as))" .
    also have "\<dots> = length (filter ((=) a) as)"
      by (induct as, auto)
    finally have filt: "n \<le> length (filter ((=) a) as)" .
    {
      assume "0 < n"
      with filt obtain b bs where "?as = b # bs" by (cases ?as, auto)
      from arg_cong[OF this, of set]
      have "a \<in> set as" by auto
      from le_1[rule_format, OF this]
      show "norm a \<le> 1" .
      note \<open>a \<in> set as\<close>
    } note mem = this
    {
      assume "norm a = 1"
      from le_N[OF mem this] filt show "n \<le> N" by (cases n, auto)
    }
  qed
qed

end


(*  Title:      ZF/OrdQuant.thy
    Authors:    Krzysztof Grabczewski and L C Paulson
*)

section \<open>Special quantifiers\<close>

theory OrdQuant imports Ordinal begin

subsection \<open>Quantifiers and union operator for ordinals\<close>

definition
  (* Ordinal Quantifiers *)
  oall :: "[i, i => o] => o"  where
    "oall A P == \<forall>x. x<A \<longrightarrow> P(x)"

definition
  oex :: "[i, i => o] => o"  where
    "oex A P  == \<exists>x. x<A & P(x)"

definition
  (* Ordinal Union *)
  OUnion :: "[i, i => i] => i"  where
    "OUnion i B == {z: \<Union>x\<in>i. B(x). Ord(i)}"

syntax
  "_oall"     :: "[idt, i, o] => o"        ("(3\<forall>_<_./ _)" 10)
  "_oex"      :: "[idt, i, o] => o"        ("(3\<exists>_<_./ _)" 10)
  "_OUNION"   :: "[idt, i, i] => i"        ("(3\<Union>_<_./ _)" 10)
translations
  "\<forall>x<a. P" \<rightleftharpoons> "CONST oall a (\<lambda>x. P)"
  "\<exists>x<a. P" \<rightleftharpoons> "CONST oex a (\<lambda>x. P)"
  "\<Union>x<a. B" \<rightleftharpoons> "CONST OUnion a (\<lambda>x. B)"

subsubsection \<open>simplification of the new quantifiers\<close>

(*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
  is proved.  Ord_atomize would convert this rule to
    x < 0 ==> P(x) == True, which causes dire effects!*)

lemma [simp]: "~(\<exists>x<0. P(x))"
by (simp add: oex_def)

lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) & (\<forall>x<i. P(x)))"
apply (simp add: oall_def le_iff)
apply (blast intro: lt_Ord2)
done

lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) & (P(i) | (\<exists>x<i. P(x))))"
apply (simp add: oex_def le_iff)
apply (blast intro: lt_Ord2)
done

subsubsection \<open>Union over ordinals\<close>

lemma Ord_OUN [intro,simp]:
     "[| !!x. x<A ==> Ord(B(x)) |] ==> Ord(\<Union>x<A. B(x))"
by (simp add: OUnion_def ltI Ord_UN)

lemma OUN_upper_lt:
     "[| a<A;  i < b(a);  Ord(\<Union>x<A. b(x)) |] ==> i < (\<Union>x<A. b(x))"
by (unfold OUnion_def lt_def, blast )

lemma OUN_upper_le:
     "[| a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x)) |] ==> i \<le> (\<Union>x<A. b(x))"
apply (unfold OUnion_def, auto)
apply (rule UN_upper_le )
apply (auto simp add: lt_def)
done

lemma Limit_OUN_eq: "Limit(i) ==> (\<Union>x<i. x) = i"
by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma OUN_least:
     "(!!x. x<A ==> B(x) \<subseteq> C) ==> (\<Union>x<A. B(x)) \<subseteq> C"
by (simp add: OUnion_def UN_least ltI)

lemma OUN_least_le:
     "[| Ord(i);  !!x. x<A ==> b(x) \<le> i |] ==> (\<Union>x<A. b(x)) \<le> i"
by (simp add: OUnion_def UN_least_le ltI Ord_0_le)

lemma le_implies_OUN_le_OUN:
     "[| !!x. x<A ==> c(x) \<le> d(x) |] ==> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)

lemma OUN_UN_eq:
     "(!!x. x \<in> A ==> Ord(B(x)))
      ==> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
by (simp add: OUnion_def)

lemma OUN_Union_eq:
     "(!!x. x \<in> X ==> Ord(x))
      ==> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
by (simp add: OUnion_def)

(*So that rule_format will get rid of this quantifier...*)
lemma atomize_oall [symmetric, rulify]:
     "(!!x. x<A ==> P(x)) == Trueprop (\<forall>x<A. P(x))"
by (simp add: oall_def atomize_all atomize_imp)

subsubsection \<open>universal quantifier for ordinals\<close>

lemma oallI [intro!]:
    "[| !!x. x<A ==> P(x) |] ==> \<forall>x<A. P(x)"
by (simp add: oall_def)

lemma ospec: "[| \<forall>x<A. P(x);  x<A |] ==> P(x)"
by (simp add: oall_def)

lemma oallE:
    "[| \<forall>x<A. P(x);  P(x) ==> Q;  ~x<A ==> Q |] ==> Q"
by (simp add: oall_def, blast)

lemma rev_oallE [elim]:
    "[| \<forall>x<A. P(x);  ~x<A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: oall_def, blast)

(*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
by blast

(*Congruence rule for rewriting*)
lemma oall_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oall a (%x. P(x)) <-> oall a' (%x. P'(x))"
by (simp add: oall_def)

subsubsection \<open>existential quantifier for ordinals\<close>

lemma oexI [intro]:
    "[| P(x);  x<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

(*Not of the general form for such rules... *)
lemma oexCI:
   "[| \<forall>x<A. ~P(x) ==> P(a);  a<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

lemma oexE [elim!]:
    "[| \<exists>x<A. P(x);  !!x. [| x<A; P(x) |] ==> Q |] ==> Q"
apply (simp add: oex_def, blast)
done

lemma oex_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oex a (%x. P(x)) <-> oex a' (%x. P'(x))"
apply (simp add: oex_def cong add: conj_cong)
done

subsubsection \<open>Rules for Ordinal-Indexed Unions\<close>

lemma OUN_I [intro]: "[| a<i;  b \<in> B(a) |] ==> b: (\<Union>z<i. B(z))"
by (unfold OUnion_def lt_def, blast)

lemma OUN_E [elim!]:
    "[| b \<in> (\<Union>z<i. B(z));  !!a.[| b \<in> B(a);  a<i |] ==> R |] ==> R"
apply (unfold OUnion_def lt_def, blast)
done

lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
by (unfold OUnion_def oex_def lt_def, blast)

lemma OUN_cong [cong]:
    "[| i=j;  !!x. x<j ==> C(x)=D(x) |] ==> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
by (simp add: OUnion_def lt_def OUN_iff)

lemma lt_induct:
    "[| i<k;  !!x.[| x<k;  \<forall>y<x. P(y) |] ==> P(x) |]  ==>  P(i)"
apply (simp add: lt_def oall_def)
apply (erule conjE)
apply (erule Ord_induct, assumption, blast)
done

subsection \<open>Quantification over a class\<close>

definition
  "rall"     :: "[i=>o, i=>o] => o"  where
    "rall M P == \<forall>x. M(x) \<longrightarrow> P(x)"

definition
  "rex"      :: "[i=>o, i=>o] => o"  where
    "rex M P == \<exists>x. M(x) & P(x)"

syntax
  "_rall"     :: "[pttrn, i=>o, o] => o"        ("(3\<forall>_[_]./ _)" 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        ("(3\<exists>_[_]./ _)" 10)
translations
  "\<forall>x[M]. P" \<rightleftharpoons> "CONST rall M (\<lambda>x. P)"
  "\<exists>x[M]. P" \<rightleftharpoons> "CONST rex M (\<lambda>x. P)"

subsubsection\<open>Relativized universal quantifier\<close>

lemma rallI [intro!]: "[| !!x. M(x) ==> P(x) |] ==> \<forall>x[M]. P(x)"
by (simp add: rall_def)

lemma rspec: "[| \<forall>x[M]. P(x); M(x) |] ==> P(x)"
by (simp add: rall_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_rallE [elim]:
    "[| \<forall>x[M]. P(x);  ~ M(x) ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: rall_def, blast)

lemma rallE: "[| \<forall>x[M]. P(x);  P(x) ==> Q;  ~ M(x) ==> Q |] ==> Q"
by blast

(*Trival rewrite rule;   (\<forall>x[M].P)<->P holds only if A is nonempty!*)
lemma rall_triv [simp]: "(\<forall>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<longrightarrow> P)"
by (simp add: rall_def)

(*Congruence rule for rewriting*)
lemma rall_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
by (simp add: rall_def)

subsubsection\<open>Relativized existential quantifier\<close>

lemma rexI [intro]: "[| P(x); M(x) |] ==> \<exists>x[M]. P(x)"
by (simp add: rex_def, blast)

(*The best argument order when there is only one M(x)*)
lemma rev_rexI: "[| M(x);  P(x) |] ==> \<exists>x[M]. P(x)"
by blast

(*Not of the general form for such rules... *)
lemma rexCI: "[| \<forall>x[M]. ~P(x) ==> P(a); M(a) |] ==> \<exists>x[M]. P(x)"
by blast

lemma rexE [elim!]: "[| \<exists>x[M]. P(x);  !!x. [| M(x); P(x) |] ==> Q |] ==> Q"
by (simp add: rex_def, blast)

(*We do not even have (\<exists>x[M]. True) <-> True unless A is nonempty!!*)
lemma rex_triv [simp]: "(\<exists>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
by (simp add: rex_def cong: conj_cong)

lemma rall_is_ball [simp]: "(\<forall>x[%z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by blast

lemma rex_is_bex [simp]: "(\<exists>x[%z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by blast

lemma atomize_rall: "(!!x. M(x) ==> P(x)) == Trueprop (\<forall>x[M]. P(x))"
by (simp add: rall_def atomize_all atomize_imp)

declare atomize_rall [symmetric, rulify]

lemma rall_simps1:
     "(\<forall>x[M]. P(x) & Q)   <-> (\<forall>x[M]. P(x)) & ((\<forall>x[M]. False) | Q)"
     "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
     "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. ~P(x))"
by blast+

lemma rall_simps2:
     "(\<forall>x[M]. P & Q(x))   <-> ((\<forall>x[M]. False) | P) & (\<forall>x[M]. Q(x))"
     "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
     "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
by blast+

lemmas rall_simps [simp] = rall_simps1 rall_simps2

lemma rall_conj_distrib:
    "(\<forall>x[M]. P(x) & Q(x)) <-> ((\<forall>x[M]. P(x)) & (\<forall>x[M]. Q(x)))"
by blast

lemma rex_simps1:
     "(\<exists>x[M]. P(x) & Q) <-> ((\<exists>x[M]. P(x)) & Q)"
     "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) & Q)"
     "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) & Q))"
     "(~(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. ~P(x))"
by blast+

lemma rex_simps2:
     "(\<exists>x[M]. P & Q(x)) <-> (P & (\<exists>x[M]. Q(x)))"
     "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) & P) | (\<exists>x[M]. Q(x))"
     "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
by blast+

lemmas rex_simps [simp] = rex_simps1 rex_simps2

lemma rex_disj_distrib:
    "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
by blast

subsubsection\<open>One-point rule for bounded quantifiers\<close>

lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
by blast

lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
by blast

lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

subsubsection\<open>Sets as Classes\<close>

definition
  setclass :: "[i,i] => o"       ("##_" [40] 40)  where
   "setclass(A) == %x. x \<in> A"

lemma setclass_iff [simp]: "setclass A x <-> x \<in> A"
by (simp add: setclass_def)

lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by auto

lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by auto

ML
\<open>
val Ord_atomize =
  atomize ([(@{const_name oall}, @{thms ospec}), (@{const_name rall}, @{thms rspec})] @
    ZF_conn_pairs, ZF_mem_pairs);
\<close>
declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

text \<open>Setting up the one-point-rule simproc\<close>

simproc_setup defined_rex ("\<exists>x[M]. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms rex_def} THEN
      Quantifier1.prove_one_point_ex_tac ctxt)
\<close>

simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms rall_def} THEN
      Quantifier1.prove_one_point_all_tac ctxt)
\<close>

end


(* Author: Tobias Nipkow *)

section "Swapping Adjacent Elements in a List"

theory Swaps
imports Inversion
begin

text\<open>Swap elements at index \<open>n\<close> and @{term "Suc n"}:\<close>

definition "swap n xs =
  (if Suc n < size xs then xs[n := xs!Suc n, Suc n := xs!n] else xs)"

lemma length_swap[simp]: "length(swap i xs) = length xs"
by(simp add: swap_def)

lemma swap_id[simp]: "Suc n \<ge> size xs \<Longrightarrow> swap n xs = xs"
by(simp add: swap_def)

lemma distinct_swap[simp]:
  "distinct(swap i xs) = distinct xs"
by(simp add: swap_def)

lemma swap_Suc[simp]: "swap (Suc n) (a # xs) = a # swap n xs"
by(induction xs) (auto simp: swap_def)

lemma index_swap_distinct:
  "distinct xs \<Longrightarrow> Suc n < length xs \<Longrightarrow>
  index (swap n xs) x =
  (if x = xs!n then Suc n else if x = xs!Suc n then n else index xs x)"
by(auto simp add: swap_def index_swap_if_distinct)

lemma set_swap[simp]: "set(swap n xs) = set xs"
by(auto simp add: swap_def set_conv_nth nth_list_update) metis

lemma nth_swap_id[simp]: "Suc i < length xs \<Longrightarrow> swap i xs ! i = xs!(i+1)"
by(simp add: swap_def)

lemma before_in_swap:
 "dist_perm xs ys \<Longrightarrow> Suc n < size xs \<Longrightarrow>
  x < y in (swap n xs) \<longleftrightarrow>
  x < y in xs \<and> \<not> (x = xs!n \<and> y = xs!Suc n) \<or> x = xs!Suc n \<and> y = xs!n"
by(simp add:before_in_def index_swap_distinct)
  (metis Suc_lessD Suc_lessI index_less_size_conv index_nth_id less_Suc_eq n_not_Suc_n nth_index)

lemma Inv_swap: assumes "dist_perm xs ys"
shows "Inv xs (swap n ys) =
  (if Suc n < size xs
   then if ys!n < ys!Suc n in xs
        then Inv xs ys \<union> {(ys!n, ys!Suc n)}
        else Inv xs ys - {(ys!Suc n, ys!n)}
   else Inv xs ys)"
proof-
  have "length xs = length ys" using assms by (metis distinct_card)
  with assms show ?thesis
    by(simp add: Inv_def set_eq_iff)
      (metis before_in_def not_before_in before_in_swap)
qed

text\<open>Perform a list of swaps, from right to left:\<close>

abbreviation swaps where "swaps == foldr swap"

lemma swaps_inv[simp]:
  "set (swaps sws xs) = set xs \<and>
  size(swaps sws xs) = size xs \<and>
  distinct(swaps sws xs) = distinct xs"
by (induct sws arbitrary: xs) (simp_all add: swap_def)

lemma swaps_eq_Nil_iff[simp]: "swaps acts xs = [] \<longleftrightarrow> xs = []"
by(induction acts)(auto simp: swap_def)

lemma swaps_map_Suc[simp]:
  "swaps (map Suc sws) (a # xs) = a # swaps sws xs"
by(induction sws arbitrary: xs) auto

lemma card_Inv_swaps_le:
  "distinct xs \<Longrightarrow> card (Inv xs (swaps sws xs)) \<le> length sws"
by(induction sws) (auto simp: Inv_swap card_insert_if card_Diff_singleton_if)

lemma nth_swaps: "\<forall>i\<in>set is. j < i \<Longrightarrow> swaps is xs ! j = xs ! j"
by(induction "is")(simp_all add: swap_def)

lemma not_before0[simp]: "~ x < xs ! 0 in xs"
apply(cases "xs = []")
by(auto simp: before_in_def neq_Nil_conv)

lemma before_id[simp]: "\<lbrakk> distinct xs; i < size xs; j < size xs \<rbrakk> \<Longrightarrow>
  xs ! i < xs ! j in xs \<longleftrightarrow> i < j"
by(simp add: before_in_def index_nth_id)

lemma before_swaps:
  "\<lbrakk> distinct is; \<forall>i\<in>set is. Suc i < size xs; distinct xs; i \<notin> set is; i < j; j < size xs \<rbrakk> \<Longrightarrow>
  swaps is xs ! i < swaps is xs ! j in xs"
apply(induction "is" arbitrary: i j)
 apply simp
apply(auto simp: swap_def nth_list_update)
done

lemma card_Inv_swaps:
  "\<lbrakk> distinct is; \<forall>i\<in>set is. Suc i < size xs; distinct xs \<rbrakk> \<Longrightarrow>
  card(Inv xs (swaps is xs)) = length is"
apply(induction "is")
 apply simp
apply(simp add: Inv_swap before_swaps card_insert_if)
apply(simp add: Inv_def)
done

lemma swaps_eq_nth_take_drop: "i < length xs \<Longrightarrow>
    swaps [0..<i] xs = xs!i # take i xs @ drop (Suc i) xs"
apply(induction i arbitrary: xs)
apply (auto simp add: neq_Nil_conv swap_def drop_update_swap
  take_Suc_conv_app_nth Cons_nth_drop_Suc[symmetric])
done

lemma index_swaps_size: "distinct s \<Longrightarrow>
  index s q \<le> index (swaps sws s) q + length sws"
apply(induction sws arbitrary: s)
apply simp
 apply (fastforce simp: swap_def index_swap_if_distinct index_nth_id)
done

lemma index_swaps_last_size: "distinct s \<Longrightarrow>
  size s \<le> index (swaps sws s) (last s) + length sws + 1"
apply(cases "s = []")
 apply simp
using index_swaps_size[of s "last s" sws] by simp

end


theory DistinctVars
imports Main "~~/src/HOL/Library/AList"
begin

abbreviation delete where "delete \<equiv> AList.delete"
abbreviation update where "update \<equiv> AList.update"

subsubsection {* The domain of a associative list *}

definition heapVars
  where "heapVars h = fst ` set h"

lemma heapVarsAppend[simp]:"heapVars (a @ b) = heapVars a \<union> heapVars b"
  and [simp]:"heapVars ((v,e) # h) = insert v (heapVars h)"
  and [simp]:"heapVars (p # h) = insert (fst p) (heapVars h)"
  and [simp]:"heapVars [] = {}"
  by (auto simp add: heapVars_def)

lemma heapVars_from_set:
  "(x, e) \<in> set h \<Longrightarrow> x \<in> heapVars h"
by (induct h, auto)

lemma finite_heapVars[simp]:
  "finite (heapVars \<Gamma>)"
  by (auto simp add: heapVars_def)

lemma delete_no_there:
  "x \<notin> heapVars \<Gamma> \<Longrightarrow> delete x \<Gamma> = \<Gamma>"
  by (induct \<Gamma>, auto)

lemma heapVars_delete[simp]:
  "heapVars (delete x \<Gamma>) = heapVars \<Gamma> - {x}"
  by (induct \<Gamma>, auto)

subsubsection {* Junk-free associative lists *}

inductive distinctVars  where
  [simp]: "distinctVars []" |
  [intro]:"x \<notin> heapVars \<Gamma> \<Longrightarrow> distinctVars \<Gamma> \<Longrightarrow> distinctVars ((x, e)  # \<Gamma>)"

lemma distinctVars_appendI:
  "distinctVars \<Gamma> \<Longrightarrow> distinctVars \<Delta> \<Longrightarrow> heapVars \<Gamma> \<inter> heapVars \<Delta> = {} \<Longrightarrow> distinctVars (\<Gamma> @ \<Delta>)"
  by (induct \<Gamma> rule:distinctVars.induct, auto)

lemma distinctVars_ConsD:
  assumes "distinctVars ((x,e) # \<Gamma>)"
  shows "x \<notin> heapVars \<Gamma>" and "distinctVars \<Gamma>"
  by (rule distinctVars.cases[OF assms], simp_all)+

lemma distinctVars_appendD:
  assumes "distinctVars (\<Gamma> @ \<Delta>)"
  shows distinctVars_appendD1: "distinctVars \<Gamma>"
  and distinctVars_appendD2: "distinctVars \<Delta>"
  and distinctVars_appendD3: "heapVars \<Gamma> \<inter> heapVars \<Delta> = {}"
proof-
  from assms
  have "distinctVars \<Gamma> \<and> distinctVars \<Delta> \<and> heapVars \<Gamma> \<inter> heapVars \<Delta> = {}"
  proof (induct \<Gamma> )
  case Nil thus ?case by simp
  next
  case (Cons p \<Gamma>)
    obtain x e where "p = (x,e)" by (metis PairE)
    with Cons have "distinctVars ((x,e) # (\<Gamma>@ \<Delta>))" by simp
    hence "x \<notin> heapVars (\<Gamma>@ \<Delta>)" and "distinctVars (\<Gamma> @ \<Delta>)" by (rule distinctVars_ConsD)+

    from `x \<notin> heapVars (\<Gamma>@ \<Delta>)` have  "x \<notin> heapVars \<Gamma>"  and "x \<notin> heapVars \<Delta>" by auto

    from Cons(1)[OF `distinctVars (\<Gamma> @ \<Delta>)`]
    have "distinctVars \<Gamma>" and "distinctVars \<Delta>" and "heapVars \<Gamma> \<inter> heapVars \<Delta> = {}" by auto
    have "distinctVars (p # \<Gamma>)"
      using `p = _` `x \<notin> heapVars \<Gamma>` `distinctVars \<Gamma>` by auto
    moreover
    have "heapVars (p # \<Gamma>) \<inter> heapVars \<Delta> = {}"
      using `p = _` `x \<notin> heapVars \<Delta>` `heapVars \<Gamma> \<inter> heapVars \<Delta> = {}` by auto
    ultimately
    show ?case using `distinctVars \<Delta>` by auto
  qed
  thus "distinctVars \<Gamma>" and "distinctVars \<Delta>" and "heapVars \<Gamma> \<inter> heapVars \<Delta> = {}" by auto
qed

lemma distinctVars_Cons:
  "distinctVars (x # \<Gamma>) \<longleftrightarrow> (fst x \<notin> heapVars \<Gamma> \<and> distinctVars \<Gamma>)"
  by (metis PairE distinctVars.intros(2) distinctVars_ConsD fst_conv)

lemma distinctVars_append:
  "distinctVars (\<Gamma> @ \<Delta>) \<longleftrightarrow> (distinctVars \<Gamma> \<and> distinctVars \<Delta> \<and> heapVars \<Gamma> \<inter> heapVars \<Delta> = {})"
  by (metis distinctVars_appendD distinctVars_appendI)

lemma distinctVars_Cons_subset:
  assumes "heapVars ((x,e)#\<Gamma>) \<subseteq> heapVars ((x,e')#\<Delta>)"
  assumes "distinctVars ((x,e)#\<Gamma>)"
  assumes "distinctVars ((x,e')#\<Delta>)"
  shows "heapVars \<Gamma> \<subseteq> heapVars \<Delta>"
proof-
  have "x \<notin> heapVars \<Gamma>" and "x \<notin> heapVars \<Delta>"
    using assms(2,3) by (metis distinctVars_ConsD(1))+
  thus ?thesis using assms(1)
    by auto
qed

lemma distinctVars_delete:
  "distinctVars \<Gamma> \<Longrightarrow> distinctVars (delete x \<Gamma>)"
  apply (induct \<Gamma> rule:distinctVars.induct)
  apply (auto simp add: distinctVars_Cons)
  done

lemma dom_map_of_conv_heapVars[simp]:
  "dom (map_of xys) = heapVars xys"
  by (induct xys) (auto simp add: dom_if)

lemma distinctVars_set_delete_insert:
  assumes "distinctVars \<Gamma>"
  assumes "(x,e) \<in> set \<Gamma>"
  shows "set ((x,e) # delete x \<Gamma>) = set \<Gamma>"
  using assms
  apply (induct \<Gamma> rule:distinctVars.induct)
  apply auto[1]
  apply (case_tac "xa = x")
  apply (auto simp add: heapVars_def)[1]
    apply (metis fst_conv imageI)
  apply auto
  done

lemma the_map_of_snd:
  "x\<in> heapVars \<Gamma> \<Longrightarrow> the (map_of \<Gamma> x) \<in> snd ` set \<Gamma>"
by (induct \<Gamma>, auto)
end


theory Reg_demo
  imports Main
begin

datatype regexp =
    Atom char
  | Star regexp
  | Alt regexp regexp
  | Conc regexp regexp (infixl "\<cdot>" 60)
  | Neg regexp

term "''abc''"
term "char_of_nat 13"

term UNIV

definition
  "Univ = Alt undefined (Neg undefined)"

definition
  "null = Neg Univ"

definition
  "epsilon = Star null"

primrec
  rrev :: "regexp \<Rightarrow> regexp"
where
  "rrev (Atom c) = Atom c"
| "rrev (Star r) = Star (rrev r)"
| "rrev (Conc r1 r2) = Conc (rrev r2) (rrev r1)"
| "rrev (Alt r1 r2) = Alt (rrev r1) (rrev r2)"
| "rrev (Neg r) = Neg (rrev r)"

type_synonym word = "char list"

definition
  conc :: "word set \<Rightarrow> word set \<Rightarrow> word set"
where
  "conc A B = { as @ bs |as bs. as \<in> A \<and> bs \<in> B }"

inductive_set
  star :: "word set \<Rightarrow> word set" for R
where
  star_empty[simp, intro!]: "[] \<in> star R"
| star_app[elim]: "\<lbrakk> xs \<in> R; ys \<in> star R \<rbrakk> \<Longrightarrow> xs @ ys \<in> star R"

primrec
  lang :: "regexp \<Rightarrow> word set"
where
  "lang (Atom c) = {[c]}"
| "lang (Alt r1 r2) = lang r1 \<union> lang r2"
| "lang (Neg r) = -lang r"
| "lang (Conc r1 r2) = conc (lang r1) (lang r2)"
| "lang (Star r) = star (lang r)"

(*
  repeatn :: nat \<Rightarrow> regexp \<Rightarrow> regexp

  star = \<Union>n. lang (repeatn n r)
*)

lemma lang_Univ[simp]:
  "lang Univ = UNIV"
  by (simp add: Univ_def)

lemma lang_null[simp]:
  "lang null = {}"
  by (simp add: null_def)

lemma star_empty[simp]:
  "star {} = {[]}"
  by (auto elim: star.cases)

lemma lang_epsilon[simp]:
  "lang epsilon = {[]}"
  by (simp add: epsilon_def)

lemma
  "lang (Alt r1 r2) = lang (Alt r2 r1)"
  by auto

lemma rev_complement[simp]:
  "- rev ` A = rev ` (- A)"
  apply (rule bij_image_Compl_eq[symmetric])
  apply (rule bijI)
   apply (rule injI)
   apply simp
  apply (rule surjI[where f=rev])
  apply simp
  done

lemma conc_rev[simp]:
  "conc (rev ` B) (rev ` A) = rev ` conc A B"
  by (fastforce simp: conc_def image_iff)

lemma star_app2[elim]:
  "\<lbrakk> a \<in> A; as \<in> star A \<rbrakk> \<Longrightarrow> as @ a \<in> star A"
  apply (erule star.induct)
   apply simp
   apply (drule star_app[where ys="[]"])
    apply simp
   apply simp
  apply auto
  done

lemma star_rev1:
  "as \<in> star (rev ` A) \<Longrightarrow> as \<in> rev ` star A"
  apply (erule star.induct)
   apply simp
  apply clarsimp
  apply (rename_tac a as)
  apply (clarsimp simp: image_iff)
  apply (rule_tac x="as @ a" in bexI)
   apply simp
  apply auto
  done

lemma rev2[simp]:
  "as \<in> star A \<Longrightarrow> rev as \<in> star (rev ` A)"
  apply (erule star.induct)
   apply simp
  apply (clarsimp simp: image_iff)
  apply (rule star_app2)
  apply auto
  done

lemma star_rev[simp]:
  "star (rev ` A) = rev ` star A"
  by (auto simp: star_rev1)

lemma "lang (rrev r) = rev ` lang r"
  by (induct r) auto

end


section {* Refinement Calculus Examples *}

theory utp_rcalc_ex
  imports "../utp_rcalc"
begin

subsection {* Initial Setup -- Example State Space *}

alphabet exstate =
  x :: int
  y :: int
  z :: int

text {* The examples in the section are taken from Carol Morgan's "Programming from Specifications". *}

subsection {* Examples from Figure 1.5 on p7 *}

term "&x:[true, &y\<^sup>2 =\<^sub>u &x]"

term "&x:[&x \<ge>\<^sub>u 0, &y\<^sup>2 =\<^sub>u &x]"

term "&e:[&s \<noteq>\<^sub>u {}\<^sub>u, &e \<in>\<^sub>u &s]"

term "&x:[&b\<^sup>2 \<ge>\<^sub>u 4*&a*&c, &a*&x\<^sup>2 + &b*&x + &c =\<^sub>u 0]"

subsection {* Exercise 1.4, first 4 questions *}

lemma "&x:[true, &x \<ge>\<^sub>u 0] \<sqsubseteq> &x:[true, &x =\<^sub>u 0]"
  by (prefine)

lemma "&x:[&x \<ge>\<^sub>u 0, true] \<sqsubseteq> &x:[&x =\<^sub>u 0, true]"
  apply (prefine)
  nitpick
  oops

lemma "&x:[&x \<ge>\<^sub>u 0, &x =\<^sub>u 0] \<sqsubseteq> &x:[&x =\<^sub>u 0, &x \<ge>\<^sub>u 0]"
  apply (prefine)
  nitpick
  oops

lemma "&x:[&x =\<^sub>u 0, &x \<ge>\<^sub>u 0] \<sqsubseteq> &x:[&x \<ge>\<^sub>u 0, &x =\<^sub>u 0]"
  by (prefine)

end


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

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

fun risers :: "int list => (int list) list" where
"risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
"lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
"msortbu2 x = mergingbu2 (risers x)"

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (msortbu2 xs)) = (count x xs))"
  oops

end


(*  Title:      HOL/Probability/Convolution.thy
    Author:     Sudeep Kanav, TU München
    Author:     Johannes Hölzl, TU München *)

section \<open>Convolution Measure\<close>

theory Convolution
  imports Independent_Family
begin

lemma (in finite_measure) sigma_finite_measure: "sigma_finite_measure M"
  ..

definition convolution :: "('a :: ordered_euclidean_space) measure \<Rightarrow> 'a measure \<Rightarrow> 'a measure" (infix "\<star>" 50) where
  "convolution M N = distr (M \<Otimes>\<^sub>M N) borel (\<lambda>(x, y). x + y)"

lemma
  shows space_convolution[simp]: "space (convolution M N) = space borel"
    and sets_convolution[simp]: "sets (convolution M N) = sets borel"
    and measurable_convolution1[simp]: "measurable A (convolution M N) = measurable A borel"
    and measurable_convolution2[simp]: "measurable (convolution M N) B = measurable borel B"
  by (simp_all add: convolution_def)

lemma nn_integral_convolution:
  assumes "finite_measure M" "finite_measure N"
  assumes [measurable_cong]: "sets N = sets borel" "sets M = sets borel"
  assumes [measurable]: "f \<in> borel_measurable borel"
  shows "(\<integral>\<^sup>+x. f x \<partial>convolution M N) = (\<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x + y) \<partial>N \<partial>M)"
proof -
  interpret M: finite_measure M by fact
  interpret N: finite_measure N by fact
  interpret pair_sigma_finite M N ..
  show ?thesis
    unfolding convolution_def
    by (simp add: nn_integral_distr N.nn_integral_fst[symmetric])
qed

lemma convolution_emeasure:
  assumes "A \<in> sets borel" "finite_measure M" "finite_measure N"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel"
  assumes [simp]: "space M = space N" "space N = space borel"
  shows "emeasure (M \<star> N) A = \<integral>\<^sup>+x. (emeasure N {a. a + x \<in> A}) \<partial>M "
  using assms by (auto intro!: nn_integral_cong simp del: nn_integral_indicator simp: nn_integral_convolution
    nn_integral_indicator [symmetric] ac_simps split:split_indicator)

lemma convolution_emeasure':
  assumes [simp]:"A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel"
  shows  "emeasure (M \<star> N) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y.  (indicator  A (x + y)) \<partial>N  \<partial>M"
  by (auto simp del: nn_integral_indicator simp: nn_integral_convolution
    nn_integral_indicator[symmetric] borel_measurable_indicator)

lemma convolution_finite:
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [measurable_cong]: "sets N = sets borel" "sets M = sets borel"
  shows "finite_measure (M \<star> N)"
  unfolding convolution_def
  by (intro finite_measure_pair_measure finite_measure.finite_measure_distr) auto

lemma convolution_emeasure_3:
  assumes [simp, measurable]: "A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N" "finite_measure L"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "emeasure (L \<star> (M \<star> N )) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. \<integral>\<^sup>+z. indicator A (x + y + z) \<partial>N \<partial>M \<partial>L"
  apply (subst nn_integral_indicator[symmetric], simp)
  apply (subst nn_integral_convolution,
        auto intro!: borel_measurable_indicator borel_measurable_indicator' convolution_finite)+
  by (rule nn_integral_cong)+ (auto simp: semigroup_add_class.add.assoc)

lemma convolution_emeasure_3':
  assumes [simp, measurable]:"A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N"  "finite_measure L"
  assumes [measurable_cong, simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "emeasure ((L \<star> M) \<star> N ) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. \<integral>\<^sup>+z. indicator A (x + y + z) \<partial>N \<partial>M \<partial>L"
  apply (subst nn_integral_indicator[symmetric], simp)+
  apply (subst nn_integral_convolution)
  apply (simp_all add: convolution_finite)
  apply (subst nn_integral_convolution)
  apply (simp_all add: finite_measure.sigma_finite_measure sigma_finite_measure.borel_measurable_nn_integral)
  done

lemma convolution_commutative:
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [measurable_cong, simp]: "sets N = sets borel" "sets M = sets borel"
  shows "(M \<star> N) = (N \<star> M)"
proof (rule measure_eqI)
  interpret M: finite_measure M by fact
  interpret N: finite_measure N by fact
  interpret pair_sigma_finite M N ..

  show "sets (M \<star> N) = sets (N \<star> M)" by simp

  fix A assume "A \<in> sets (M \<star> N)"
  then have 1[measurable]:"A \<in> sets borel" by simp
  have "emeasure (M \<star> N) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator A (x + y) \<partial>N \<partial>M" by (auto intro!: convolution_emeasure')
  also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. (\<lambda>(x,y). indicator A (x + y)) (x, y) \<partial>N \<partial>M" by (auto intro!: nn_integral_cong)
  also have "... = \<integral>\<^sup>+y. \<integral>\<^sup>+x. (\<lambda>(x,y). indicator A (x + y)) (x, y) \<partial>M \<partial>N" by (rule Fubini[symmetric]) simp
  also have "... = emeasure (N \<star> M) A" by (auto intro!: nn_integral_cong simp: add.commute convolution_emeasure')
  finally show "emeasure (M \<star> N) A = emeasure (N \<star> M) A" by simp
qed

lemma convolution_associative:
  assumes [simp]: "finite_measure M" "finite_measure N"  "finite_measure L"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "(L \<star> (M \<star> N)) = ((L \<star> M) \<star> N)"
  by (auto intro!: measure_eqI simp: convolution_emeasure_3 convolution_emeasure_3')

lemma (in prob_space) sum_indep_random_variable:
  assumes ind: "indep_var borel X borel Y"
  assumes [simp, measurable]: "random_variable borel X"
  assumes [simp, measurable]: "random_variable borel Y"
  shows "distr M borel (\<lambda>x. X x + Y x) = convolution (distr M borel X)  (distr M borel Y)"
  using ind unfolding indep_var_distribution_eq convolution_def
  by (auto simp: distr_distr intro!:arg_cong[where f = "distr M borel"])

lemma (in prob_space) sum_indep_random_variable_lborel:
  assumes ind: "indep_var borel X borel Y"
  assumes [simp, measurable]: "random_variable lborel X"
  assumes [simp, measurable]:"random_variable lborel Y"
  shows "distr M lborel (\<lambda>x. X x + Y x) = convolution (distr M lborel X)  (distr M lborel Y)"
  using ind unfolding indep_var_distribution_eq convolution_def
  by (auto simp: distr_distr o_def intro!: arg_cong[where f = "distr M borel"] cong: distr_cong)

lemma convolution_density:
  fixes f g :: "real \<Rightarrow> ennreal"
  assumes [measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
  assumes [simp]:"finite_measure (density lborel f)" "finite_measure (density lborel g)"
  shows "density lborel f \<star> density lborel g = density lborel (\<lambda>x. \<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel)"
    (is "?l = ?r")
proof (intro measure_eqI)
  fix A assume "A \<in> sets ?l"
  then have [measurable]: "A \<in> sets borel"
    by simp

  have "(\<integral>\<^sup>+x. f x * (\<integral>\<^sup>+y. g y * indicator A (x + y) \<partial>lborel) \<partial>lborel) =
    (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. g y * (f x * indicator A (x + y)) \<partial>lborel) \<partial>lborel)"
  proof (intro nn_integral_cong_AE, eventually_elim)
    fix x
    have "f x * (\<integral>\<^sup>+ y. g y * indicator A (x + y) \<partial>lborel) =
      (\<integral>\<^sup>+ y. f x * (g y * indicator A (x + y)) \<partial>lborel)"
      by (intro nn_integral_cmult[symmetric]) auto
    then show "f x * (\<integral>\<^sup>+ y. g y * indicator A (x + y) \<partial>lborel) =
      (\<integral>\<^sup>+ y. g y * (f x * indicator A (x + y)) \<partial>lborel)"
      by (simp add: ac_simps)
  qed
  also have "\<dots> = (\<integral>\<^sup>+y. (\<integral>\<^sup>+x. g y * (f x * indicator A (x + y)) \<partial>lborel) \<partial>lborel)"
    by (intro lborel_pair.Fubini') simp
  also have "\<dots> = (\<integral>\<^sup>+y. (\<integral>\<^sup>+x. f (x - y) * g y * indicator A x \<partial>lborel) \<partial>lborel)"
  proof (intro nn_integral_cong_AE, eventually_elim)
    fix y
    have "(\<integral>\<^sup>+x. g y * (f x * indicator A (x + y)) \<partial>lborel) =
      g y * (\<integral>\<^sup>+x. f x * indicator A (x + y) \<partial>lborel)"
      by (intro nn_integral_cmult) auto
    also have "\<dots> = g y * (\<integral>\<^sup>+x. f (x - y) * indicator A x \<partial>lborel)"
      by (subst nn_integral_real_affine[where c=1 and t="-y"])
         (auto simp add: one_ennreal_def[symmetric])
    also have "\<dots> = (\<integral>\<^sup>+x. g y * (f (x - y) * indicator A x) \<partial>lborel)"
      by (intro nn_integral_cmult[symmetric]) auto
    finally show "(\<integral>\<^sup>+ x. g y * (f x * indicator A (x + y)) \<partial>lborel) =
      (\<integral>\<^sup>+ x. f (x - y) * g y * indicator A x \<partial>lborel)"
      by (simp add: ac_simps)
  qed
  also have "\<dots> = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. f (x - y) * g y * indicator A x \<partial>lborel) \<partial>lborel)"
    by (intro lborel_pair.Fubini') simp
  finally show "emeasure ?l A = emeasure ?r A"
    by (auto simp: convolution_emeasure' nn_integral_density emeasure_density
      nn_integral_multc)
qed simp

lemma (in prob_space) distributed_finite_measure_density:
  "distributed M N X f \<Longrightarrow> finite_measure (density N f)"
  using finite_measure_distr[of X N] distributed_distr_eq_density[of M N X f] by simp

lemma (in prob_space) distributed_convolution:
  fixes f :: "real \<Rightarrow> _"
  fixes g :: "real \<Rightarrow> _"
  assumes indep: "indep_var borel X borel Y"
  assumes X: "distributed M lborel X f"
  assumes Y: "distributed M lborel Y g"
  shows "distributed M lborel (\<lambda>x. X x + Y x) (\<lambda>x. \<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel)"
  unfolding distributed_def
proof safe
  have fg[measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
    using distributed_borel_measurable[OF X] distributed_borel_measurable[OF Y] by simp_all

  show "(\<lambda>x. \<integral>\<^sup>+ xa. f (x - xa) * g xa \<partial>lborel) \<in> borel_measurable lborel"
    by measurable

  have "distr M borel (\<lambda>x. X x + Y x) = (distr M borel X \<star> distr M borel Y)"
    using distributed_measurable[OF X] distributed_measurable[OF Y]
    by (intro sum_indep_random_variable) (auto simp: indep)
  also have "\<dots> = (density lborel f \<star> density lborel g)"
    using distributed_distr_eq_density[OF X] distributed_distr_eq_density[OF Y]
    by (simp cong: distr_cong)
  also have "\<dots> = density lborel (\<lambda>x. \<integral>\<^sup>+ y. f (x - y) * g y \<partial>lborel)"
  proof (rule convolution_density)
    show "finite_measure (density lborel f)"
      using X by (rule distributed_finite_measure_density)
    show "finite_measure (density lborel g)"
      using Y by (rule distributed_finite_measure_density)
  qed fact+
  finally show "distr M lborel (\<lambda>x. X x + Y x) = density lborel (\<lambda>x. \<integral>\<^sup>+ y. f (x - y) * g y \<partial>lborel)"
    by (simp cong: distr_cong)
  show "random_variable lborel (\<lambda>x. X x + Y x)"
    using distributed_measurable[OF X] distributed_measurable[OF Y] by simp
qed

lemma prob_space_convolution_density:
  fixes f:: "real \<Rightarrow> _"
  fixes g:: "real \<Rightarrow> _"
  assumes [measurable]: "f\<in> borel_measurable borel"
  assumes [measurable]: "g\<in> borel_measurable borel"
  assumes gt_0[simp]: "\<And>x. 0 \<le> f x" "\<And>x. 0 \<le> g x"
  assumes "prob_space (density lborel f)" (is "prob_space ?F")
  assumes "prob_space (density lborel g)" (is "prob_space ?G")
  shows "prob_space (density lborel (\<lambda>x.\<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel))" (is "prob_space ?D")
proof (subst convolution_density[symmetric])
  interpret F: prob_space ?F by fact
  show "finite_measure ?F" by unfold_locales
  interpret G: prob_space ?G by fact
  show "finite_measure ?G" by unfold_locales
  interpret FG: pair_prob_space ?F ?G ..

  show "prob_space (density lborel f \<star> density lborel g)"
    unfolding convolution_def by (rule FG.prob_space_distr) simp
qed simp_all

end


subsection \<open>Sorting\<close>

text \<open>Some preliminary lemmas about sorting.\<close>

theory Sorting
  imports Main "HOL.List" "HOL-Library.Sublist"
begin

lemma insort:
  assumes "Suc l < length s"
  assumes "s ! l < (v :: 'a :: linorder)"
  assumes "s ! (l+1) > v"
  assumes "sorted_wrt (<) s"
  shows "sorted_wrt (<) ((take (Suc l) s)@v#(drop (Suc l) s))"
proof -
  have "sorted_wrt (<) (take (Suc l) s@(drop (Suc l) s))"
    using assms(4) by simp
  moreover have
    "\<And>x. x \<in> set (take (Suc l) s) = (\<exists>i. i < (Suc l) \<and> i < length s \<and> s ! i = x)"
    by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)
  hence "\<And>x. x \<in> set (take (Suc l) s) \<Longrightarrow> x < v"
    using assms apply (simp)
    using less_Suc_eq sorted_wrt_nth_less by fastforce
  moreover have
    "\<And>x. x \<in> set (drop (Suc l) s) = (\<exists>i. Suc l + i < length s \<and> s ! (Suc l + i) = x)"
    using assms(1) by (simp add:in_set_conv_nth add.commute less_diff_conv)
  hence "\<And>x. x \<in> set (drop (Suc l) s) \<Longrightarrow> x > v"
    using assms apply (simp)
    by (metis add.right_neutral add_diff_cancel_left' diff_Suc_Suc diff_is_0_eq'
        leI le_less_trans less_imp_le sorted_wrt_iff_nth_less)
  ultimately show ?thesis
    by (simp add:sorted_wrt_append del:append_take_drop_id)
qed

lemma sorted_wrt_irrefl_distinct:
  assumes "irreflp r"
  shows "sorted_wrt r xs \<longrightarrow> distinct xs"
  using assms by (induction xs, simp, simp, meson irreflp_def)

lemma sort_set_unique_h:
  assumes "irreflp r \<and> transp r"
  assumes "set (x#xs) = set (y#ys)"
  assumes "\<forall>z \<in> set xs. r x z"
  assumes "\<forall>z \<in> set ys. r y z"
  shows "x = y \<and> set xs = set ys"
  by (metis assms insert_eq_iff irreflp_def list.set_intros(1)
      list.simps(15) set_ConsD transpD)

lemma sort_set_unique_rel:
  assumes "irreflp r \<and> transp r"
  assumes "set x = set y"
  assumes "sorted_wrt r x"
  assumes "sorted_wrt r y"
  shows "x = y"
proof -
  have "length x = length y"
    using assms by (metis sorted_wrt_irrefl_distinct distinct_card)
  then show ?thesis using assms
    apply(induct rule:list_induct2, simp, simp)
    by (metis assms(1) list.simps(15) sort_set_unique_h)
qed

lemma sort_set_unique:
  assumes "set x = set y"
  assumes "sorted_wrt (<) (map (f :: ('a \<Rightarrow> ('b :: linorder)))  x)"
  assumes "sorted_wrt (<) (map f y)"
  shows "x = y"
  using assms apply (simp add:sorted_wrt_map)
  by (metis (no_types, lifting) irreflp_def less_irrefl sort_set_unique_rel
      transpD transpI transp_less)

text \<open>If two sequences contain the same element and strictly increasing with respect.\<close>

lemma subseq_imp_sorted:
  assumes "subseq s t"
  assumes "sorted_wrt p t"
  shows "sorted_wrt p s"
proof -
  have "sorted_wrt p s \<or> \<not> sorted_wrt p t"
  apply (rule list_emb.induct[where P="(=)"])
  using list_emb_set assms by fastforce+
  thus ?thesis using assms by blast
qed

text \<open>If a sequence @{text t} is sorted with respect to a relation @{text p} then a subsequence will
  be as well.\<close>

fun to_ord where "to_ord r x y = (\<not>(r\<^sup>*\<^sup>* y x))"

lemma trancl_idemp: "r\<^sup>+\<^sup>+\<^sup>+\<^sup>+ x y = r\<^sup>+\<^sup>+ x y"
  by (metis r_into_rtranclp reflclp_tranclp rtranclp_idemp rtranclp_reflclp
      rtranclp_tranclp_tranclp tranclp.cases tranclp.r_into_trancl)

lemma top_sort:
  fixes rp
  assumes "acyclicP r"
  shows "finite s \<longrightarrow> (\<exists>l. set l = s \<and> sorted_wrt (to_ord r) l \<and> distinct l)"
proof (induction "card s" arbitrary:s)
  case 0
  then show ?case by auto
next
  case (Suc n)
  hence "s \<noteq> {}" by auto
  moreover
  have "acyclicP (r\<^sup>+\<^sup>+)" using assms
    by (simp add:acyclic_def trancl_def trancl_idemp)
  hence "acyclic ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s)"
    by (meson acyclic_subset inf_le1)
  hence "wf ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s)" using Suc
    by (metis card_infinite finite_Int finite_SigmaI nat.distinct(1)
        wf_iff_acyclic_if_finite)
  ultimately obtain z where
    "z \<in> s \<and> (\<forall>y. (y, z) \<in>  ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s) \<longrightarrow> y \<notin> s)"
    by (metis ex_in_conv wf_eq_minimal)
  hence z_def: "z \<in> s \<and> (\<forall>y. r\<^sup>+\<^sup>+ y z \<longrightarrow> y \<notin> s)" by blast
  hence "card (s - {z}) = n"
    by (metis One_nat_def Suc.hyps(2) card_Diff_singleton_if card_infinite
        diff_Suc_Suc diff_zero nat.simps(3))
  then obtain l where l_def:
    "set l = s - {z} \<and> sorted_wrt (to_ord r) l \<and> distinct l"
    by (metis Zero_not_Suc card_infinite finite_Diff Suc)
  hence "set (z#l) = s" using z_def by auto
  moreover have "\<forall>y \<in> set l. \<not>(r\<^sup>*\<^sup>* y z)" using z_def l_def rtranclpD by force
  ultimately show ?case
    by (metis distinct.simps(2) insert_absorb l_def list.simps(15)
        sorted_wrt.simps(2) to_ord.elims(3))
qed

lemma top_sort_eff:
  assumes "irreflp p\<^sup>+\<^sup>+"
  assumes "sorted_wrt (to_ord p) x"
  assumes "i < length x"
  assumes "j < length x"
  assumes "(p\<^sup>+\<^sup>+ (x ! i) (x ! j))"
  shows "i < j"
  using assms apply (cases "i > j")
   apply (metis sorted_wrt_nth_less r_into_rtranclp reflclp_tranclp
          rtranclp_idemp rtranclp_reflclp to_ord.simps)
  by (metis irreflp_def nat_neq_iff)

end