(* author: Thiemann *)

section \<open>Roots of Unity\<close>

theory Roots_Unity
imports
  Polynomial_Factorization.Order_Polynomial
  "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
  Polynomial_Interpolation.Ring_Hom_Poly
begin

lemma cis_mult_cmod_id: "cis (Arg x) * of_real (cmod x) = x"
  using rcis_cmod_Arg[unfolded rcis_def] by (simp add: ac_simps)

lemma rcis_mult_cis[simp]: "rcis n a * cis b = rcis n (a + b)" unfolding cis_rcis_eq rcis_mult by simp
lemma rcis_div_cis[simp]: "rcis n a / cis b = rcis n (a - b)" unfolding cis_rcis_eq rcis_divide by simp

lemma cis_plus_2pi[simp]: "cis (x + 2 * pi) = cis x" by (auto simp: complex_eq_iff)
lemma cis_plus_2pi_neq_1: assumes x: "0 < x" "x < 2 * pi"
  shows "cis x \<noteq> 1"
proof -
  from x have "cos x \<noteq> 1" by (smt cos_2pi_minus cos_monotone_0_pi cos_zero)
  thus ?thesis by (auto simp: complex_eq_iff)
qed

lemma cis_times_2pi[simp]: "cis (of_nat n * 2 * pi) = 1"
proof (induct n)
  case (Suc n)
  have "of_nat (Suc n) * 2 * pi = of_nat n * 2 * pi + 2 * pi" by (simp add: distrib_right)
  also have "cis \<dots> = 1" unfolding cis_plus_2pi Suc ..
  finally show ?case .
qed simp

lemma cis_add_pi[simp]: "cis (pi + x) = - cis x"
  by (auto simp: complex_eq_iff)

lemma cis_3_pi_2[simp]: "cis (pi * 3 / 2) = - \<i>"
proof -
  have "cis (pi * 3 / 2) = cis (pi + pi / 2)"
    by (rule arg_cong[of _ _ cis], simp)
  also have "\<dots> = - \<i>" unfolding cis_add_pi by simp
  finally show ?thesis .
qed

lemma rcis_plus_2pi[simp]: "rcis y (x + 2 * pi) = rcis y x" unfolding rcis_def by simp
lemma rcis_times_2pi[simp]: "rcis r (of_nat n * 2 * pi) = of_real r"
  unfolding rcis_def cis_times_2pi by simp

lemma arg_rcis_cis: assumes n: "n > 0" shows "Arg (rcis n x) = Arg (cis x)"
  using Arg_bounded cis_Arg_unique cis_Arg complex_mod_rcis n rcis_def sgn_eq by auto

lemma arg_eqD: assumes "Arg (cis x) = Arg (cis y)" "-pi < x" "x \<le> pi" "-pi < y" "y \<le> pi"
  shows "x = y"
  using assms(1) unfolding cis_Arg_unique[OF sgn_cis assms(2-3)] cis_Arg_unique[OF sgn_cis assms(4-5)] .

lemma rcis_inj_on: assumes r: "r \<noteq> 0" shows "inj_on (rcis r) {0 ..< 2 * pi}"
proof (rule inj_onI, goal_cases)
  case (1 x y)
  from arg_cong[OF 1(3), of "\<lambda> x. x / r"] have "cis x = cis y" using r by (simp add: rcis_def)
  from arg_cong[OF this, of "\<lambda> x. inverse x"] have "cis (-x) = cis (-y)" by simp
  from arg_cong[OF this, of uminus] have *: "cis (-x + pi) = cis (-y + pi)"
    by (auto simp: complex_eq_iff)
  have "- x + pi = - y + pi"
    by (rule arg_eqD[OF arg_cong[OF *, of Arg]], insert 1(1-2), auto)
  thus ?case by simp
qed

lemma cis_inj_on: "inj_on cis {0 ..< 2 * pi}"
  using rcis_inj_on[of 1] unfolding rcis_def by auto

definition root_unity :: "nat \<Rightarrow> 'a :: comm_ring_1 poly" where
  "root_unity n = monom 1 n - 1"

lemma poly_root_unity: "poly (root_unity n) x = 0 \<longleftrightarrow> x^n = 1"
  unfolding root_unity_def by (simp add: poly_monom)

lemma degree_root_unity[simp]: "degree (root_unity n) = n" (is "degree ?p = _")
proof -
  have p: "?p = monom 1 n + (-1)" unfolding root_unity_def by auto
  show ?thesis
  proof (cases n)
    case 0
    thus ?thesis unfolding p by simp
  next
    case (Suc m)
    show ?thesis unfolding p unfolding Suc
      by (subst degree_add_eq_left, auto simp: degree_monom_eq)
  qed
qed

lemma zero_root_unit[simp]: "root_unity n = 0 \<longleftrightarrow> n = 0" (is "?p = 0 \<longleftrightarrow> _")
proof (cases "n = 0")
  case True
  thus ?thesis unfolding root_unity_def by simp
next
  case False
  from degree_root_unity[of n] False
  have "degree ?p \<noteq> 0" by auto
  hence "?p \<noteq> 0" by fastforce
  thus ?thesis using False by auto
qed

definition prod_root_unity :: "nat list \<Rightarrow> 'a :: idom poly" where
  "prod_root_unity ns = prod_list (map root_unity ns)"

lemma poly_prod_root_unity: "poly (prod_root_unity ns) x = 0 \<longleftrightarrow> (\<exists>k\<in>set ns. x ^ k = 1)"
  unfolding prod_root_unity_def
  by (simp add: poly_prod_list prod_list_zero_iff o_def image_def poly_root_unity)

lemma degree_prod_root_unity[simp]: "0 \<notin> set ns \<Longrightarrow> degree (prod_root_unity ns) = sum_list ns"
  unfolding prod_root_unity_def
  by (subst degree_prod_list_eq, auto simp: o_def)

lemma zero_prod_root_unit[simp]: "prod_root_unity ns = 0 \<longleftrightarrow> 0 \<in> set ns"
  unfolding prod_root_unity_def prod_list_zero_iff by auto

lemma roots_of_unity: assumes n: "n \<noteq> 0"
  shows "(\<lambda> i. (cis (of_nat i * 2 * pi / n))) ` {0 ..< n} = { x :: complex. x ^ n = 1}" (is "?prod = ?Roots")
     "{x. poly (root_unity n) x = 0} = { x :: complex. x ^ n = 1}"
     "card { x :: complex. x ^ n = 1} = n"
proof (atomize(full), goal_cases)
  case 1
  let ?one = "1 :: complex"
  let ?p = "monom ?one n - 1"
  have degM: "degree (monom ?one n) = n" by (rule degree_monom_eq, simp)
  have "degree ?p = degree (monom ?one n + (-1))" by simp
  also have "\<dots> = degree (monom ?one n)"
    by (rule degree_add_eq_left, insert n, simp add: degM)
  finally have degp: "degree ?p = n" unfolding degM .
  with n have p: "?p \<noteq> 0" by auto
  have roots: "?Roots = {x. poly ?p x = 0}"
    unfolding poly_diff poly_monom by simp
  also have "finite \<dots>" by (rule poly_roots_finite[OF p])
  finally have fin: "finite ?Roots" .
  have sub: "?prod \<subseteq> ?Roots"
  proof
    fix x
    assume "x \<in> ?prod"
    then obtain i where x: "x = cis (real i * 2 * pi / n)" by auto
    have "x ^ n = cis (real i * 2 * pi)" unfolding x DeMoivre using n by simp
    also have "\<dots> = 1" by simp
    finally show "x \<in> ?Roots" by auto
  qed
  have Rn: "card ?Roots \<le> n" unfolding roots
    by (rule poly_roots_degree[of ?p, unfolded degp, OF p])
  have "\<dots> = card {0 ..< n}" by simp
  also have "\<dots> = card ?prod"
  proof (rule card_image[symmetric], rule inj_onI, goal_cases)
    case (1 x y)
    {
      fix m
      assume "m < n"
      hence "real m < real n" by simp
      from mult_strict_right_mono[OF this, of "2 * pi / real n"] n
      have "real m * 2 * pi / real n < real n * 2 * pi / real n" by simp
      hence "real m * 2 * pi / real n < 2 * pi" using n by simp
    } note [simp] = this
    have 0: "(1 :: real) \<noteq> 0" using n by auto
    have "real x * 2 * pi / real n = real y * 2 * pi / real n"
      by (rule inj_onD[OF rcis_inj_on 1(3)[unfolded cis_rcis_eq]], insert 1(1-2), auto)
    with n show "x = y" by auto
  qed
  finally have cn:  "card ?prod = n" ..
  with Rn have "card ?prod \<ge> card ?Roots" by auto
  with card_mono[OF fin sub] have card: "card ?prod = card ?Roots" by auto
  have "?prod = ?Roots"
    by (rule card_subset_eq[OF fin sub card])
  from this roots[symmetric] cn[unfolded this]
  show ?case unfolding root_unity_def by blast
qed

lemma poly_roots_dvd: fixes p :: "'a :: field poly"
  assumes "p \<noteq> 0" and "degree p = n"
  and "card {x. poly p x = 0} \<ge> n" and "{x. poly p x = 0} \<subseteq> {x. poly q x = 0}"
shows "p dvd q"
proof -
  from poly_roots_degree[OF assms(1)] assms(2-3) have "card {x. poly p x = 0} = n" by auto
  from assms(1-2) this assms(4)
  show ?thesis
  proof (induct n arbitrary: p q)
    case (0 p q)
    from is_unit_iff_degree[OF 0(1)] 0(2) show ?case by blast
  next
    case (Suc n p q)
    let ?P = "{x. poly p x = 0}"
    let ?Q = "{x. poly q x = 0}"
    from Suc(4-5) card_gt_0_iff[of ?P] obtain x where
      x: "poly p x = 0" "poly q x = 0" and fin: "finite ?P" by auto
    define r where "r = [:-x, 1:]"
    from x[unfolded poly_eq_0_iff_dvd r_def[symmetric]] obtain p' q' where
      p: "p = r * p'" and q: "q = r * q'" unfolding dvd_def by auto
    from Suc(2) have "degree p = degree r + degree p'" unfolding p
      by (subst degree_mult_eq, auto)
    with Suc(3) have deg: "degree p' = n" unfolding r_def by auto
    from Suc(2) p have p'0: "p' \<noteq> 0" by auto
    let ?P' = "{x. poly p' x = 0}"
    let ?Q' = "{x. poly q' x = 0}"
    have P: "?P = insert x ?P'" unfolding p poly_mult unfolding r_def by auto
    have Q: "?Q = insert x ?Q'" unfolding q poly_mult unfolding r_def by auto
    {
      assume "x \<in> ?P'"
      hence "?P = ?P'" unfolding P by auto
      from arg_cong[OF this, of card, unfolded Suc(4)] deg have False
        using poly_roots_degree[OF p'0] by auto
    } note xp' = this
    hence xP': "x \<notin> ?P'" by auto
    have "card ?P = Suc (card ?P')" unfolding P
      by (rule card_insert_disjoint[OF _ xP'], insert fin[unfolded P], auto)
    with Suc(4) have card: "card ?P' = n" by auto
    from Suc(5)[unfolded P Q] xP' have "?P' \<subseteq> ?Q'" by auto
    from Suc(1)[OF p'0 deg card this]
    have IH: "p' dvd q'" .
    show ?case unfolding p q using IH by simp
  qed
qed

lemma root_unity_decomp: assumes n: "n \<noteq> 0"
  shows "root_unity n =
    prod_list (map (\<lambda> i. [:-cis (of_nat i * 2 * pi / n), 1:]) [0 ..< n])" (is "?u = ?p")
proof -
  have deg: "degree ?u = n" by simp
  note main = roots_of_unity[OF n]
  have dvd: "?u dvd ?p"
  proof (rule poly_roots_dvd[OF _ deg])
    show "n \<le> card {x. poly ?u x = 0}" using main by auto
    show "?u \<noteq> 0" using n by auto
    show "{x. poly ?u x = 0} \<subseteq> {x. poly ?p x = 0}"
      unfolding main(2) main(1)[symmetric] poly_prod_list prod_list_zero_iff by auto
  qed
  have deg': "degree ?p = n"
    by (subst degree_prod_list_eq, auto simp: o_def sum_list_triv)
  have mon: "monic ?u" using deg unfolding root_unity_def using n by auto
  have mon': "monic ?p" by (rule monic_prod_list, auto)
  from dvd[unfolded dvd_def] obtain f where puf: "?p = ?u * f" by auto
  have "degree ?p = degree ?u + degree f" using mon' n unfolding puf
    by (subst degree_mult_eq, auto)
  with deg deg' have "degree f = 0" by auto
  from degree0_coeffs[OF this] obtain a where f: "f = [:a:]" by blast
  from arg_cong[OF puf, of lead_coeff] mon mon'
  have "a = 1" unfolding puf f by (cases "a = 0", auto)
  with f have f: "f = 1" by auto
  with puf show ?thesis by auto
qed

lemma order_monic_linear: "order x [:y,1:] = (if y + x = 0 then 1 else 0)"
proof (cases "y + x = 0")
  case True
  hence "poly [:y,1:] x = 0" by simp
  from this[unfolded order_root] have "order x [:y,1:] \<noteq> 0" by auto
  moreover from order_degree[of "[:y,1:]" x] have "order x [:y,1:] \<le> 1" by auto
  ultimately show ?thesis unfolding True by auto
next
  case False
  hence "poly [:y,1:] x \<noteq> 0" by auto
  from order_0I[OF this] False show ?thesis by auto
qed

lemma order_root_unity: fixes x :: complex assumes n: "n \<noteq> 0"
  shows "order x (root_unity n) = (if x^n = 1 then 1 else 0)"
  (is "order _ ?u = _")
proof (cases "x^n = 1")
  case False
  with roots_of_unity(2)[OF n] have "poly ?u x \<noteq> 0" by auto
  from False order_0I[OF this] show ?thesis by auto
next
  case True
  let ?phi = "\<lambda> i :: nat. i * 2 * pi / n"
  from True roots_of_unity(1)[OF n] obtain i where i: "i < n"
    and x: "x = cis (?phi i)" by force
  from i have n_split: "[0 ..< n] = [0 ..< i] @ i # [Suc i ..< n]"
    by (metis le_Suc_ex less_imp_le_nat not_le_imp_less not_less0 upt_add_eq_append upt_conv_Cons)
  {
    fix j
    assume j: "j < n \<or> j < i" and eq: "cis (?phi i) = cis (?phi j)"
    from inj_onD[OF cis_inj_on eq] i j n have "i = j" by (auto simp: field_simps)
  } note inj = this
  have "order x ?u = 1" unfolding root_unity_decomp[OF n]
    unfolding x n_split using inj
    by (subst order_prod_list, force, fastforce simp: order_monic_linear)
  with True show ?thesis by auto
qed

lemma order_prod_root_unity: assumes 0: "0 \<notin> set ks"
  shows "order (x :: complex) (prod_root_unity ks) = length (filter (\<lambda> k. x^k = 1) ks)"
proof -
  have "order x (prod_root_unity ks) = (\<Sum>k\<leftarrow>ks. order x (root_unity k))"
    unfolding prod_root_unity_def
    by (subst order_prod_list, insert 0, auto simp: o_def)
  also have "\<dots> = (\<Sum>k\<leftarrow>ks. (if x^k = 1 then 1 else 0))"
    by (rule arg_cong, rule map_cong, insert 0, force, intro order_root_unity, metis)
  also have "\<dots> = length (filter (\<lambda> k. x^k = 1) ks)"
    by (subst sum_list_map_filter'[symmetric], simp add: sum_list_triv)
  finally show ?thesis .
qed

lemma root_unity_witness: fixes xs :: "complex list"
  assumes "prod_list (map (\<lambda> x. [:-x,1:]) xs) = monom 1 n - 1"
  shows "x^n = 1 \<longleftrightarrow> x \<in> set xs"
proof -
  from assms have n0: "n \<noteq> 0" by (cases "n = 0", auto simp: prod_list_zero_iff)
  have "x \<in> set xs \<longleftrightarrow> poly (prod_list (map (\<lambda> x. [:-x,1:]) xs)) x = 0"
    unfolding poly_prod_list prod_list_zero_iff by auto
  also have "\<dots> \<longleftrightarrow> x^n = 1" using roots_of_unity(2)[OF n0] unfolding assms root_unity_def by auto
  finally show ?thesis by auto
qed

lemma root_unity_explicit: fixes x :: complex
  shows
    "(x ^ 1 = 1) \<longleftrightarrow> x = 1"
    "(x ^ 2 = 1) \<longleftrightarrow> (x \<in> {1, -1})"
    "(x ^ 3 = 1) \<longleftrightarrow> (x \<in> {1, Complex (-1/2) (sqrt 3 / 2), Complex (-1/2) (- sqrt 3 / 2)})"
    "(x ^ 4 = 1) \<longleftrightarrow> (x \<in> {1, -1, \<i>, - \<i>})"
proof -
  show "(x ^ 1 = 1) \<longleftrightarrow> x = 1"
    by (subst root_unity_witness[of "[1]"], code_simp, auto)
  show "(x ^ 2 = 1) \<longleftrightarrow> (x \<in> {1, -1})"
    by (subst root_unity_witness[of "[1,-1]"], code_simp, auto)
  show "(x ^ 4 = 1) \<longleftrightarrow> (x \<in> {1, -1, \<i>, - \<i>})"
    by (subst root_unity_witness[of "[1,-1, \<i>, - \<i>]"], code_simp, auto)
  have 3: "3 = Suc (Suc (Suc 0))" "1 = [:1:]" by auto
  show "(x ^ 3 = 1) \<longleftrightarrow> (x \<in> {1, Complex (-1/2) (sqrt 3 / 2), Complex (-1/2) (- sqrt 3 / 2)})"
    by (subst root_unity_witness[of
      "[1, Complex (-1/2) (sqrt 3 / 2), Complex (-1/2) (- sqrt 3 / 2)]"],
      auto simp: 3 monom_altdef complex_mult complex_eq_iff)
qed

definition primitive_root_unity :: "nat \<Rightarrow> 'a :: power \<Rightarrow> bool" where
  "primitive_root_unity k x = (k \<noteq> 0 \<and> x^k = 1 \<and> (\<forall> k' < k. k' \<noteq> 0 \<longrightarrow> x^k' \<noteq> 1))"

lemma primitive_root_unityD: assumes "primitive_root_unity k x"
  shows "k \<noteq> 0" "x^k = 1" "k' \<noteq> 0 \<Longrightarrow> x^k' = 1 \<Longrightarrow> k \<le> k'"
proof -
  note * = assms[unfolded primitive_root_unity_def]
  from * have **: "k' < k \<Longrightarrow> k' \<noteq> 0 \<Longrightarrow> x ^ k' \<noteq> 1" by auto
  show "k \<noteq> 0" "x^k = 1" using * by auto
  show "k' \<noteq> 0 \<Longrightarrow> x^k' = 1 \<Longrightarrow> k \<le> k'" using ** by force
qed

lemma primitive_root_unity_exists: assumes "k \<noteq> 0" "x ^ k = 1"
  shows "\<exists> k'. k' \<le> k \<and> primitive_root_unity k' x"
proof -
  let ?P = "\<lambda> k. x ^ k = 1 \<and> k \<noteq> 0"
  define k' where "k' = (LEAST k. ?P k)"
  from assms have Pk: "\<exists> k. ?P k" by auto
  from LeastI_ex[OF Pk, folded k'_def]
  have "k' \<noteq> 0" "x ^ k' = 1" by auto
  with not_less_Least[of _ ?P, folded k'_def]
  have "primitive_root_unity k' x" unfolding primitive_root_unity_def by auto
  with primitive_root_unityD(3)[OF this assms]
  show ?thesis by auto
qed

lemma primitive_root_unity_dvd: fixes x :: "complex"
  assumes k: "primitive_root_unity k x"
  shows "x ^ n = 1 \<longleftrightarrow> k dvd n"
proof
  assume "k dvd n" then obtain j where n: "n = k * j" unfolding dvd_def by auto
  have "x ^ n = (x ^ k) ^ j" unfolding n power_mult by simp
  also have "\<dots> = 1" unfolding primitive_root_unityD[OF k] by simp
  finally show "x ^ n = 1" .
next
  assume n: "x ^ n = 1"
  note k = primitive_root_unityD[OF k]
  show "k dvd n"
  proof (cases "n = 0")
    case n0: False
    from k(3)[OF n0] n have nk: "n \<ge> k" by force
    from roots_of_unity[OF k(1)] k(2) obtain i :: nat where xk: "x = cis (i * 2 * pi / k)"
      and ik: "i < k" by force
    from roots_of_unity[OF n0] n obtain j :: nat where xn: "x = cis (j * 2 * pi / n)"
      and jn: "j < n" by force
    have cop: "coprime i k"
    proof (rule gcd_eq_1_imp_coprime)
      from k(1) have "gcd i k \<noteq> 0" by auto
      from gcd_coprime_exists[OF this] this obtain i' k' g where
        *: "i = i' * g" "k = k' * g" "g \<noteq> 0" and g: "g = gcd i k" by blast
      from *(2) k(1) have k': "k' \<noteq> 0" by auto
      have "x = cis (i * 2 * pi / k)" by fact
      also have "i * 2 * pi / k = i' * 2 * pi / k'" unfolding * using *(3) by auto
      finally have "x ^ k' = 1" by (simp add: DeMoivre k')
      with k(3)[OF k'] have "k' \<ge> k" by linarith
      moreover with * k(1) have "g = 1" by auto
      then show "gcd i k = 1" by (simp add: g)
    qed
    from inj_onD[OF cis_inj_on xk[unfolded xn]] n0 k(1) ik jn
    have "j * real k = i * real n" by (auto simp: field_simps)
    hence "real (j * k) = real (i * n)" by simp
    hence eq: "j * k = i * n" by linarith
    with cop show "k dvd n"
      by (metis coprime_commute coprime_dvd_mult_right_iff dvd_triv_right)
  qed auto
qed

lemma primitive_root_unity_simple_computation:
  "primitive_root_unity k x  = (if k = 0 then False else
     x ^ k = 1 \<and> (\<forall> i \<in> {1 ..< k}. x ^ i \<noteq> 1))"
  unfolding primitive_root_unity_def by auto

lemma primitive_root_unity_explicit: fixes x :: complex
  shows "primitive_root_unity 1 x \<longleftrightarrow> x = 1"
    "primitive_root_unity 2 x \<longleftrightarrow> x = -1"
    "primitive_root_unity 3 x \<longleftrightarrow> (x \<in> {Complex (-1/2) (sqrt 3 / 2), Complex (-1/2) (- sqrt 3 / 2)})"
    "primitive_root_unity 4 x \<longleftrightarrow> (x \<in> {\<i>, - \<i>})"
proof (atomize(full), goal_cases)
  case 1
  {
    fix P :: "nat \<Rightarrow> bool"
    have *: "{1 ..< 2 :: nat} = {1}" "{1 ..< 3 :: nat} = {1,2}" "{1 ..< 4 :: nat} = {1,2,3}"
      by code_simp+
    have "(\<forall>i\<in> {1 ..< 2}. P i) = P 1" "(\<forall>i\<in> {1 ..< 3}. P i) \<longleftrightarrow> P 1 \<and> P 2"
      "(\<forall>i\<in> {1 ..< 4}. P i) \<longleftrightarrow> P 1 \<and> P 2 \<and> P 3"
      unfolding * by auto
  } note * = this
  show ?case unfolding primitive_root_unity_simple_computation root_unity_explicit *
    by (auto simp: complex_eq_iff)
qed

function decompose_prod_root_unity_main ::
  "'a :: field poly \<Rightarrow> nat \<Rightarrow> nat list \<times> 'a poly" where
  "decompose_prod_root_unity_main p k = (
    if k = 0 then ([], p) else
   let q = root_unity k in if q dvd p then if p = 0 then ([],0) else
     map_prod (Cons k) id (decompose_prod_root_unity_main (p div q) k) else
     decompose_prod_root_unity_main p (k - 1))"
  by pat_completeness auto

termination by (relation "measure (\<lambda> (p,k). degree p + k)", auto simp: degree_div_less)

declare decompose_prod_root_unity_main.simps[simp del]

lemma decompose_prod_root_unity_main: fixes p :: "complex poly"
  assumes p: "p = prod_root_unity ks * f"
  and d: "decompose_prod_root_unity_main p k = (ks',g)"
  and f: "\<And> x. cmod x = 1 \<Longrightarrow> poly f x \<noteq> 0"
  and k: "\<And> k'. k' > k \<Longrightarrow> \<not> root_unity k' dvd p"
shows "p = prod_root_unity ks' * f \<and> f = g \<and> set ks = set ks'"
  using d p k
proof (induct p k arbitrary: ks ks' rule: decompose_prod_root_unity_main.induct)
  case (1 p k ks ks')
  note p = 1(4)
  note k = 1(5)
  from k[of "Suc k"] have p0: "p \<noteq> 0" by auto
  hence "p = 0 \<longleftrightarrow> False" by auto
  note d = 1(3)[unfolded decompose_prod_root_unity_main.simps[of p k] this if_False Let_def]
  from p0[unfolded p] have ks0: "0 \<notin> set ks" by simp
  from f[of 1] have f0: "f \<noteq> 0" by auto
  note IH = 1(1)[OF _ refl _ p0] 1(2)[OF _ refl]
  show ?case
  proof (cases "k = 0")
    case True
    with p k[unfolded this, of "hd ks"] p0 have "ks = []"
      by (cases ks, auto simp: prod_root_unity_def)
    with d p True show ?thesis by (auto simp: prod_root_unity_def)
  next
    case k0: False
    note IH = IH[OF k0]
    from k0 have "k = 0 \<longleftrightarrow> False" by auto
    note d = d[unfolded this if_False]
    let ?u = "root_unity k :: complex poly"
    show ?thesis
    proof (cases "?u dvd p")
      case True
      note IH = IH(1)[OF True]
      let ?call = "decompose_prod_root_unity_main (p div ?u) k"
      from True d obtain Ks where rec: "?call = (Ks,g)" and ks': "ks' = (k # Ks)"
        by (cases ?call, auto)
      from True have "?u dvd p \<longleftrightarrow> True" by simp
      note d = d[unfolded this if_True rec]
      let ?x = "cis (2 * pi / k)"
      have rt: "poly ?u ?x = 0" unfolding poly_root_unity using cis_times_2pi[of 1]
        by (simp add: DeMoivre)
      with True have "poly p ?x = 0" unfolding dvd_def by auto
      from this[unfolded p] f[of ?x] rt have "poly (prod_root_unity ks) ?x = 0"
        unfolding poly_root_unity by auto
      from this[unfolded poly_prod_root_unity] ks0 obtain k' where k': "k' \<in> set ks"
        and rt: "?x ^ k' = 1" and k'0: "k' \<noteq> 0" by auto
      let ?u' = "root_unity k' :: complex poly"
      from k' rt k'0 have rtk': "poly ?u' ?x = 0" unfolding poly_root_unity by auto
      {
        let ?phi = " k' * (2 * pi / k)"
        assume "k' < k"
        hence "0 < ?phi" "?phi < 2 * pi" using k0 k'0 by (auto simp: field_simps)
        from cis_plus_2pi_neq_1[OF this] rtk'
        have False unfolding poly_root_unity DeMoivre ..
      }
      hence kk': "k \<le> k'" by presburger
      {
        assume "k' > k"
        from k[OF this, unfolded p]
        have "\<not> ?u' dvd prod_root_unity ks" using dvd_mult2 by auto
        with k' have False unfolding prod_root_unity_def
          using prod_list_dvd[of ?u' "map root_unity ks"] by auto
      }
      with kk' have kk': "k' = k" by presburger
      with k' have "k \<in> set ks" by auto
      from split_list[OF this] obtain ks1 ks2 where ks: "ks = ks1 @ k # ks2" by auto
      hence "p div ?u = (?u * (prod_root_unity (ks1 @ ks2) * f)) div ?u"
        by (simp add: ac_simps p prod_root_unity_def)
      also have "\<dots> = prod_root_unity (ks1 @ ks2) * f"
        by (rule nonzero_mult_div_cancel_left, insert k0, auto)
      finally have id: "p div ?u = prod_root_unity (ks1 @ ks2) * f" .
      from d have ks': "ks' = k # Ks" by auto
      have "k < k' \<Longrightarrow> \<not> root_unity k' dvd p div ?u" for k'
        using k[of k'] True by (metis dvd_div_mult_self dvd_mult2)
      from IH[OF rec id this]
      have id: "p div root_unity k = prod_root_unity Ks * f" and
        *: "f = g \<and> set (ks1 @ ks2) = set Ks" by auto
      from arg_cong[OF id, of "\<lambda> x. x * ?u"] True
      have "p = prod_root_unity Ks * f * root_unity k" by auto
      thus ?thesis using * unfolding ks ks' by (auto simp: prod_root_unity_def)
    next
      case False
      from d False have "decompose_prod_root_unity_main p (k - 1) = (ks',g)" by auto
      note IH = IH(2)[OF False this p]
      have k: "k - 1 < k' \<Longrightarrow> \<not> root_unity k' dvd p" for k' using False k[of k'] k0
        by (cases "k' = k", auto)
      show ?thesis by (rule IH, insert False k, auto)
    qed
  qed
qed

definition "decompose_prod_root_unity p = decompose_prod_root_unity_main p (degree p)"

lemma decompose_prod_root_unity: fixes p :: "complex poly"
  assumes p: "p = prod_root_unity ks * f"
  and d: "decompose_prod_root_unity p = (ks',g)"
  and f: "\<And> x. cmod x = 1 \<Longrightarrow> poly f x \<noteq> 0"
  and p0: "p \<noteq> 0"
shows "p = prod_root_unity ks' * f \<and> f = g \<and> set ks = set ks'"
proof (rule decompose_prod_root_unity_main[OF p d[unfolded decompose_prod_root_unity_def] f])
  fix k
  assume deg: "degree p < k"
  hence "degree p < degree (root_unity k)" by simp
  with p0 show "\<not> root_unity k dvd p"
    by (simp add: poly_divides_conv0)
qed

lemma (in comm_ring_hom) hom_root_unity: "map_poly hom (root_unity n) = root_unity n"
proof -
  interpret p: map_poly_comm_ring_hom hom ..
  show ?thesis unfolding root_unity_def
    by (simp add: hom_distribs)
qed

lemma (in idom_hom) hom_prod_root_unity: "map_poly hom (prod_root_unity n) = prod_root_unity n"
proof -
  interpret p: map_poly_comm_ring_hom hom ..
  show ?thesis unfolding prod_root_unity_def p.hom_prod_list map_map o_def hom_root_unity ..
qed

lemma (in field_hom) hom_decompose_prod_root_unity_main:
  "decompose_prod_root_unity_main (map_poly hom p) k = map_prod id (map_poly hom)
    (decompose_prod_root_unity_main p k)"
proof (induct p k rule: decompose_prod_root_unity_main.induct)
  case (1 p k)
  let ?h = "map_poly hom"
  let ?p = "?h p"
  let ?u = "root_unity k :: 'a poly"
  let ?u' = "root_unity k :: 'b poly"
  interpret p: map_poly_inj_idom_divide_hom hom ..
  have u': "?u' = ?h ?u" unfolding hom_root_unity ..
  note simp = decompose_prod_root_unity_main.simps
  let ?rec1 = "decompose_prod_root_unity_main (p div ?u) k"
  have 0: "?p = 0 \<longleftrightarrow> p = 0" by simp
  show ?case
    unfolding simp[of ?p k] simp[of p k] if_distrib[of "map_prod id ?h"] Let_def u'
    unfolding 0 p.hom_div[symmetric] p.hom_dvd_iff
    by (rule if_cong[OF refl], force, rule if_cong[OF refl if_cong[OF refl]], force,
     (subst 1(1), auto, cases ?rec1, auto)[1],
     (subst 1(2), auto))
qed

lemma (in field_hom) hom_decompose_prod_root_unity:
  "decompose_prod_root_unity (map_poly hom p) = map_prod id (map_poly hom)
    (decompose_prod_root_unity p)"
  unfolding decompose_prod_root_unity_def
  by (subst hom_decompose_prod_root_unity_main, simp)

end


theory Missing_Multiset2
  imports "HOL-Library.Multiset" "HOL-Library.Permutation" "HOL-Library.Permutations"
    Containers.Containers_Auxiliary (* only for a lemma *)
begin

subsubsection \<open>Missing muiltiset\<close>

lemma id_imp_bij:
  assumes id: "\<And>x. f (f x) = x" shows "bij f"
proof (intro bijI injI surjI[of f, OF id])
  fix x y assume "f x = f y"
  then have "f (f x) = f (f y)" by auto
  with id show "x = y" by auto
qed

lemma rel_mset_Zero_iff[simp]:
  shows "rel_mset rel {#} Y \<longleftrightarrow> Y = {#}" and "rel_mset rel X {#} \<longleftrightarrow> X = {#}"
  using rel_mset_Zero rel_mset_size by (fastforce, fastforce)

definition "is_mset_set X \<equiv> \<forall>x \<in># X. count X x = 1"

lemma is_mset_setD[dest]: "is_mset_set X \<Longrightarrow> x \<in># X \<Longrightarrow> count X x = 1"
  unfolding is_mset_set_def by auto

lemma is_mset_setI[intro]:
  assumes "\<And>x. x \<in># X \<Longrightarrow> count X x = 1"
  shows "is_mset_set X"
  using assms unfolding is_mset_set_def by auto

lemma is_mset_set[simp]: "is_mset_set (mset_set X)"
  unfolding is_mset_set_def
  by (meson count_mset_set(1) count_mset_set(2) count_mset_set(3) not_in_iff)

lemma is_mset_set_add[simp]:
  "is_mset_set (X + {#x#}) \<longleftrightarrow> is_mset_set X \<and> x \<notin># X" (is "?L \<longleftrightarrow> ?R")
proof(intro iffI conjI)
  assume L: ?L
  with count_eq_zero_iff count_single show "is_mset_set X"
    unfolding is_mset_set_def
    by (metis (no_types, hide_lams) add_mset_add_single count_add_mset nat.inject set_mset_add_mset_insert union_single_eq_member)
  show "x \<notin># X"
  proof
    assume "x \<in># X"
    then have "count (X + {#x#}) x > 1" by auto
    with L show False by (auto simp: is_mset_set_def)
  qed
next
  assume R: ?R show ?L
  proof
    fix x' assume x': "x' \<in># X + {#x#}"
    show "count (X + {#x#}) x' = 1"
    proof(cases "x' \<in># X")
      case True with R have "count X x' = 1" by auto
        moreover from True R have "count {#x#} x' = 0" by auto
        ultimately show ?thesis by auto
    next
      case False then have "count X x' = 0" by (simp add: not_in_iff)
        with R x' show ?thesis by auto
    qed
  qed
qed

lemma count_image_mset:
  shows "count (image_mset f X) y = (\<Sum>x | x \<in># X \<and> y = f x. count X x)"
proof(induct X)
  case empty show ?case by auto
next
  case (add x X)
    define X' where "X' \<equiv> X + {#x#}"
    have "(\<Sum>z | z \<in># X' \<and> y = f z. count (X + {#x#}) z) =
          (\<Sum>z | z \<in># X' \<and> y = f z. count X z) + (\<Sum>z | z \<in># X' \<and> y = f z. count {#x#} z)"
      unfolding plus_multiset.rep_eq sum.distrib..
    also have split:
      "{z. z \<in># X' \<and> y = f z} =
       {z. z \<in># X' \<and> y = f z \<and> z \<noteq> x} \<union> {z. z \<in># X' \<and> y = f z \<and> z = x}" by blast
    then have "(\<Sum>z | z \<in># X' \<and> y = f z. count {#x#} z) =
      (\<Sum>z | z \<in># X' \<and> y = f z \<and> z = x. count {#x#} z)"
      unfolding split by (subst sum.union_disjoint, auto)
    also have "... = (if y = f x then 1 else 0)" using card_eq_Suc_0_ex1 by (auto simp: X'_def)
    also have "(\<Sum>z | z \<in># X' \<and> y = f z. count X z) = (\<Sum>z | z \<in># X \<and> y = f z. count X z)"
    proof(cases "x \<in># X")
      case True then have "z \<in># X' \<longleftrightarrow> z \<in># X" for z by (auto simp: X'_def)
      then show ?thesis by auto
    next
      case False
        have split: "{z. z \<in># X' \<and> y = f z} = {z. z \<in># X \<and> y = f z} \<union> {z. z = x \<and> y = f z}"
          by (auto simp: X'_def)
        also have "sum (count X) ... = (\<Sum>z | z \<in># X \<and> y = f z. count X z) + (\<Sum>z | z = x \<and> y = f z. count X z)"
          by (subst sum.union_disjoint, auto simp: False)
        also with False have "\<And>z. z = x \<and> y = f z \<Longrightarrow> count X z = 0" by (meson count_inI)
        with sum.neutral_const have "(\<Sum>z | z = x \<and> y = f z. count X z) = 0" by auto
        finally show ?thesis by auto
    qed
    also have "... = count (image_mset f X) y" using add by auto
    finally show ?case by (simp add: X'_def)
qed

lemma is_mset_set_image:
  assumes "inj_on f (set_mset X)" and "is_mset_set X"
  shows "is_mset_set (image_mset f X)"
proof (cases X)
  case empty then show ?thesis by auto
next
  case (add x X)
    define X' where "X' \<equiv> add_mset x X"
    with assms add have inj:"inj_on f (set_mset X')"
          and X': "is_mset_set X'" by auto
  show ?thesis
  proof(unfold add, intro is_mset_setI, fold X'_def)
    fix y assume "y \<in># image_mset f X'"
    then have "y \<in> f ` set_mset X'" by auto
    with inj have "\<exists>!x'. x' \<in># X' \<and> y = f x'" by (meson imageE inj_onD)
    then obtain x' where x': "{x'. x' \<in># X' \<and> y = f x'} = {x'}" by auto
    then have "count (image_mset f X') y = count X' x'"
      unfolding count_image_mset by auto
    also from X' x' have "... = 1" by auto
    finally show "count (image_mset f X') y = 1".
  qed
qed

(* a variant for "right" *)

  define ysa where "ysa = take j ys' @ drop (Suc j) ys'"
  have "mset ys' = {#y#} + mset ysa"
    unfolding ysa_def using j_len nth_j
    by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
        append_take_drop_id mset.simps(2) mset_append)
  hence ms_y: "mset ysa = mset ys"
    by (simp add: Cons.prems)
  then obtain xsa where
    len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
    using Cons.hyps(2) by blast

  define xs' where "xs' = take j xsa @ x # drop j xsa"
  have ys': "ys' = take j ysa @ y # drop j ysa"
    using ms_y j_len nth_j Cons.prems ysa_def
    by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
      length_drop size_mset)
  have j_len': "j \<le> length ysa"
    using j_len ys' ysa_def
    by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
  have "length ys' = length xs'"
    unfolding xs'_def using Cons.prems len_a ms_y
    by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
  moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
    unfolding ys' xs'_def
    apply (rule HOL.trans[OF mset_zip_take_Cons_drop_twice])
    using j_len' by (auto simp: len_a ms_a)
  ultimately show ?case
    by blast
qed

lemma list_all2_reorder_right_invariance:
  assumes rel: "list_all2 R xs ys" and ms_y: "mset ys' = mset ys"
  shows "\<exists>xs'. list_all2 R xs' ys' \<and> mset xs' = mset xs"
proof -
  have len: "length xs = length ys"
    using rel list_all2_conv_all_nth by auto
  obtain xs' where
    len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
    using len ms_y by (metis ex_mset_zip_right)
  have "list_all2 R xs' ys'"
    using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
  moreover have "mset xs' = mset xs"
    using len len' ms_xy map_fst_zip mset_map by metis
  ultimately show ?thesis
    by blast
qed

lemma rel_mset_via_perm: "rel_mset rel (mset xs) (mset ys) \<longleftrightarrow> (\<exists>zs. perm xs zs \<and> list_all2 rel zs ys)"
proof (unfold rel_mset_def, intro iffI, goal_cases)
  case 1
  then obtain zs ws where zs: "mset zs = mset xs" and ws: "mset ws = mset ys" and zsws: "list_all2 rel zs ws" by auto
  note list_all2_reorder_right_invariance[OF zsws ws[symmetric], unfolded zs mset_eq_perm]
  then show ?case using perm_sym by auto
next
  case 2
  from this[folded mset_eq_perm] show ?case by force
qed

lemma rel_mset_free:
  assumes rel: "rel_mset rel X Y" and xs: "mset xs = X"
  shows "\<exists>ys. mset ys = Y \<and> list_all2 rel xs ys"
proof-
  from rel[unfolded rel_mset_def] obtain xs' ys'
    where xs': "mset xs' = X" and ys': "mset ys' = Y" and xsys': "list_all2 rel xs' ys'" by auto
  from xs' xs have "mset xs = mset xs'" by auto
  from mset_eq_permutation[OF this]
  obtain f where perm: "f permutes {..<length xs'}" and xs': "permute_list f xs' = xs".
  then have [simp]: "length xs' = length xs" by auto
  from permute_list_nth[OF perm, unfolded xs'] have *: "\<And>i. i < length xs \<Longrightarrow> xs ! i = xs' ! f i" by auto
  note [simp] = list_all2_lengthD[OF xsys',symmetric]
  note [simp] = atLeast0LessThan[symmetric]
  note bij =  permutes_bij[OF perm]
  define ys where "ys \<equiv> map (nth ys' \<circ> f) [0..<length ys']"
  then have [simp]: "length ys = length ys'" by auto
  have "mset ys = mset (map (nth ys') (map f [0..<length ys']))"
   unfolding ys_def by auto
  also have "... = image_mset (nth ys') (image_mset f (mset [0..<length ys']))"
    by (simp add: multiset.map_comp)
  also have "(mset [0..<length ys']) = mset_set {0..<length ys'}"
    by (metis mset_sorted_list_of_multiset sorted_list_of_mset_set sorted_list_of_set_range)
  also have "image_mset f (...) = mset_set (f ` {..<length ys'})"
    using subset_inj_on[OF bij_is_inj[OF bij]] by (subst image_mset_mset_set, auto)
  also have "... = mset [0..<length ys']" using perm by (simp add: permutes_image)
  also have "image_mset (nth ys') ... = mset ys'" by(fold mset_map, unfold map_nth, auto)
  finally have "mset ys = Y" using ys' by auto
  moreover have "list_all2 rel xs ys"
  proof(rule list_all2_all_nthI)
    fix i assume i: "i < length xs"
    with * have "xs ! i = xs' ! f i" by auto
    also from i permutes_in_image[OF perm]
    have "rel (xs' ! f i) (ys' ! f i)" by (intro list_all2_nthD[OF xsys'], auto)
    finally show "rel (xs ! i) (ys ! i)" unfolding ys_def using i by simp
  qed simp
  ultimately show ?thesis by auto
qed

lemma rel_mset_split:
  assumes rel: "rel_mset rel (X1+X2) Y"
  shows "\<exists>Y1 Y2. Y = Y1 + Y2 \<and> rel_mset rel X1 Y1 \<and> rel_mset rel X2 Y2"
proof-
  obtain xs1 where xs1: "mset xs1 = X1" using ex_mset by auto
  obtain xs2 where xs2: "mset xs2 = X2" using ex_mset by auto
  from xs1 xs2 have "mset (xs1 @ xs2) = X1 + X2" by auto
  from rel_mset_free[OF rel this] obtain ys
    where ys: "mset ys = Y" "list_all2 rel (xs1 @ xs2) ys" by auto
  then obtain ys1 ys2
    where ys12: "ys = ys1 @ ys2"
      and xs1ys1: "list_all2 rel xs1 ys1"
      and xs2ys2: "list_all2 rel xs2 ys2"
    using list_all2_append1 by blast
  from ys12 ys have "Y = mset ys1 + mset ys2" by auto
  moreover from xs1 xs1ys1 have "rel_mset rel X1 (mset ys1)" unfolding rel_mset_def by auto
  moreover from xs2 xs2ys2 have "rel_mset rel X2 (mset ys2)" unfolding rel_mset_def by auto
  ultimately show ?thesis by (subst exI[of _ "mset ys1"], subst exI[of _ "mset ys2"],auto)
qed

lemma rel_mset_OO:
  assumes AB: "rel_mset R A B" and BC: "rel_mset S B C"
  shows "rel_mset (R OO S) A C"
proof-
  from AB obtain as bs where A_as: "A = mset as" and B_bs: "B = mset bs" and as_bs: "list_all2 R as bs"
    by (auto simp: rel_mset_def)
  from rel_mset_free[OF BC] B_bs obtain cs where C_cs: "C = mset cs" and bs_cs: "list_all2 S bs cs"
    by auto
  from list_all2_trans[OF _ as_bs bs_cs, of "R OO S"] A_as C_cs
  show ?thesis by (auto simp: rel_mset_def)
qed

end


(* Title:      Matrix Model of Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Matrices\<close>

theory Matrix
imports "HOL-Library.Word" Dioid
begin

text \<open>In this section we formalise a perhaps more natural version of
matrices of fixed dimension ($m \times n$-matrices). It is well known
that such matrices over a Kleene algebra form a Kleene
algebra~\cite{conway71regular}.\<close>

subsection \<open>Type Definition\<close>

typedef (overloaded) 'a atMost = "{..<LENGTH('a::len)}"
by auto

declare Rep_atMost_inject [simp]

lemma UNIV_atMost:
  "(UNIV::'a atMost set) = Abs_atMost ` {..<LENGTH('a::len)}"
 apply auto
 apply (rule Abs_atMost_induct)
 apply auto
done

lemma finite_UNIV_atMost [simp]: "finite (UNIV::('a::len) atMost set)"
  by (simp add: UNIV_atMost)

text \<open>Our matrix type is similar to \mbox{\<open>'a^'n^'m\<close>} from
{\em HOL/Multivariate\_Analysis/Finite\_Cartesian\_Product.thy}, but
(i)~we explicitly define a type constructor for matrices and square
matrices, and (ii)~in the definition of operations, e.g., matrix
multiplication, we impose weaker sort requirements on the element
type.\<close>

context notes [[typedef_overloaded]]
begin

datatype ('a,'m,'n) matrix = Matrix "'m atMost \<Rightarrow> 'n atMost \<Rightarrow> 'a"

datatype ('a,'m) sqmatrix = SqMatrix "'m atMost \<Rightarrow> 'm atMost \<Rightarrow> 'a"

end

fun sqmatrix_of_matrix where
  "sqmatrix_of_matrix (Matrix A) = SqMatrix A"

fun matrix_of_sqmatrix where
  "matrix_of_sqmatrix (SqMatrix A) = Matrix A"

subsection \<open>0 and 1\<close>

instantiation matrix :: (zero,type,type) zero
begin
  definition zero_matrix_def: "0 \<equiv> Matrix (\<lambda>i j. 0)"
  instance ..
end

instantiation sqmatrix :: (zero,type) zero
begin
  definition zero_sqmatrix_def: "0 \<equiv> SqMatrix (\<lambda>i j. 0)"
  instance ..
end

text \<open>Tricky sort issues: compare @{term one_matrix} with @{term
one_sqmatrix} \dots\<close>

instantiation matrix :: ("{zero,one}",len,len) one
begin
  definition one_matrix_def:
    "1 \<equiv> Matrix (\<lambda>i j. if Rep_atMost i = Rep_atMost j then 1 else 0)"
  instance ..
end

instantiation sqmatrix :: ("{zero,one}",type) one
begin
  definition one_sqmatrix_def:
    "1 \<equiv> SqMatrix (\<lambda>i j. if i = j then 1 else 0)"
  instance ..
end

subsection \<open>Matrix Addition\<close>

fun matrix_plus where
  "matrix_plus (Matrix A) (Matrix B) = Matrix (\<lambda>i j. A i j + B i j)"

instantiation matrix :: (plus,type,type) plus
begin
  definition plus_matrix_def: "A + B \<equiv> matrix_plus A B"
  instance ..
end

lemma plus_matrix_def' [simp]:
  "Matrix A + Matrix B = Matrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_matrix_def)

instantiation sqmatrix :: (plus,type) plus
begin
  definition plus_sqmatrix_def:
    "A + B \<equiv> sqmatrix_of_matrix (matrix_of_sqmatrix A + matrix_of_sqmatrix B)"
  instance ..
end

lemma plus_sqmatrix_def' [simp]:
  "SqMatrix A + SqMatrix B = SqMatrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_sqmatrix_def)

lemma matrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma matrix_add_assoc:
  "(A::('a::semigroup_add,'m,'n) matrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma matrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + (B + C) = B + (A + C)"
  by (metis matrix_add_assoc matrix_add_commute)

lemma sqmatrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma sqmatrix_add_assoc:
  "(A::('a::semigroup_add,'m) sqmatrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma sqmatrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + (B + C) = B + (A + C)"
  by (metis sqmatrix_add_commute sqmatrix_add_assoc)

subsection \<open>Order (via Addition)\<close>

instantiation matrix :: (plus,type,type) plus_ord
begin
  definition less_eq_matrix_def:
    "(A::('a, 'b, 'c) matrix) \<le> B \<equiv> A + B = B"
  definition less_matrix_def:
    "(A::('a, 'b, 'c) matrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b, 'c) matrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_matrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_matrix_def)
  qed
end

instantiation sqmatrix :: (plus,type) plus_ord
begin
  definition less_eq_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) \<le> B \<equiv> A + B = B"
  definition less_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b) sqmatrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_sqmatrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_sqmatrix_def)
  qed
end

subsection \<open>Matrix Multiplication\<close>

fun matrix_times :: "('a::{comm_monoid_add,times},'m,'k) matrix \<Rightarrow> ('a,'k,'n) matrix \<Rightarrow> ('a,'m,'n) matrix" where
  "matrix_times (Matrix A) (Matrix B) = Matrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"

notation matrix_times (infixl "*\<^sub>M" 70)

instantiation sqmatrix :: ("{comm_monoid_add,times}",type) times
begin
  definition times_sqmatrix_def:
    "A * B = sqmatrix_of_matrix (matrix_of_sqmatrix A *\<^sub>M matrix_of_sqmatrix B)"
  instance ..
end

lemma times_sqmatrix_def' [simp]:
  "SqMatrix A * SqMatrix B = SqMatrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"
  by (simp add: times_sqmatrix_def)

lemma matrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) *\<^sub>M 0 = 0"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_mult_0_left [simp]:
  "0 *\<^sub>M (A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) = 0"
  by (cases A, simp add: zero_matrix_def)

lemma sum_delta_r_0 [simp]:
  "\<lbrakk> finite S; j \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_r_1 [simp]:
  "\<lbrakk> finite S; j \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = f j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) *\<^sub>M 1 = A"
  by (cases A, simp add: one_matrix_def)

lemma sum_delta_l_0 [simp]:
  "\<lbrakk> finite S; i \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_l_1 [simp]:
  "\<lbrakk> finite S; i \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = f i j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_left [simp]:
  "1 *\<^sub>M (A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) = A"
  by (cases A, simp add: one_matrix_def)

lemma matrix_mult_assoc:
  "(A::('a::semiring_0,'m,'n) matrix) *\<^sub>M B *\<^sub>M C = A *\<^sub>M (B *\<^sub>M C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma matrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) *\<^sub>M (B + C) = A *\<^sub>M B + A *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma matrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) + B) *\<^sub>M C = A *\<^sub>M C + B *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

lemma sqmatrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) * 0 = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_0_left [simp]:
  "0 * (A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) * 1 = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_1_left [simp]:
  "1 * (A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_assoc:
  "(A::('a::{semiring_0,monoid_mult},'m) sqmatrix) * B * C = A * (B * C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma sqmatrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) * (B + C) = A * B + A * C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma sqmatrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) + B) * C = A * C + B * C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

subsection \<open>Square-Matrix Model of Dioids\<close>

text \<open>The following subclass proofs are necessary to connect parts
of our algebraic hierarchy to the hierarchy found in the Isabelle/HOL
library.\<close>

subclass (in ab_near_semiring_one_zerol) comm_monoid_add
proof
  fix a :: 'a
  show "0 + a = a"
    by (fact add_zerol)
qed

subclass (in semiring_one_zero) semiring_0
proof
  fix a :: 'a
  show "0 * a = 0"
    by (fact annil)
  show "a * 0 = 0"
    by (fact annir)
qed

subclass (in ab_near_semiring_one) monoid_mult ..

instantiation sqmatrix :: (dioid_one_zero,len) dioid_one_zero
begin
  instance
  proof
    fix A B C :: "('a, 'b) sqmatrix"
    show "A + B + C = A + (B + C)"
      by (fact sqmatrix_add_assoc)
    show "A + B = B + A"
      by (fact sqmatrix_add_commute)
    show "A * B * C = A * (B * C)"
      by (fact sqmatrix_mult_assoc)
    show "(A + B) * C = A * C + B * C"
      by (fact sqmatrix_mult_distrib_right)
    show "1 * A = A"
      by (fact sqmatrix_mult_1_left)
    show "A * 1 = A"
      by (fact sqmatrix_mult_1_right)
    show "0 + A = A"
      by (fact sqmatrix_add_0_left)
    show "0 * A = 0"
      by (fact sqmatrix_mult_0_left)
    show "A * 0 = 0"
      by (fact sqmatrix_mult_0_right)
    show "A + A = A"
      by (cases A, simp)
    show "A * (B + C) = A * B + A * C"
      by (fact sqmatrix_mult_distrib_left)
  qed
end

subsection \<open>Kleene Star for Matrices\<close>

text \<open>We currently do not implement the Kleene star of matrices,
since this is complicated.\<close>

end


(* Title: Negligible.thy
  Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Negligibility\<close>

theory Negligible imports
  Complex_Main
  Landau_Symbols.Landau_More
begin

named_theorems negligible_intros

definition negligible :: "(nat \<Rightarrow> real) \<Rightarrow> bool" (* TODO: generalise types? *)
where "negligible f \<longleftrightarrow> (\<forall>c>0. f \<in> o(\<lambda>x. inverse (x powr c)))"

lemma negligibleD:
  "\<lbrakk> negligible f; c > 0 \<rbrakk> \<Longrightarrow> f \<in> o(\<lambda>x. inverse (x powr c))"
unfolding negligible_def by(simp)

lemma negligibleD_real:
  assumes "negligible f"
  shows "f \<in> o(\<lambda>x. inverse (x powr c))"
proof -
  let ?c = "max 1 c"
  have "f \<in> o(\<lambda>x. inverse (x powr ?c))" using assms by(rule negligibleD) simp
  also have "(\<lambda>x. x powr c) \<in> O(\<lambda>x. real x powr max 1 c)"
    by(rule bigoI[where c=1])(auto simp add: eventually_at_top_linorder intro!: exI[where x=1] powr_mono)
  then have "(\<lambda>x. inverse (real x powr max 1 c)) \<in> O(\<lambda>x. inverse (x powr c))"
    by(auto simp add: eventually_at_top_linorder exI[where x=1] intro: landau_o.big.inverse)
  finally show ?thesis .
qed

lemma negligible_mono: "\<lbrakk> negligible g; f \<in> O(g) \<rbrakk> \<Longrightarrow> negligible f"
by(rule negligibleI)(drule (1) negligibleD; erule (1) landau_o.big_small_trans)

lemma negligible_le: "\<lbrakk> negligible g; \<And>\<eta>. \<bar>f \<eta>\<bar> \<le> g \<eta> \<rbrakk> \<Longrightarrow> negligible f"
by(erule negligible_mono)(force intro: order_trans intro!: eventually_sequentiallyI landau_o.big_mono)

lemma negligible_K0 [negligible_intros, simp, intro!]: "negligible (\<lambda>_. 0)"
by(rule negligibleI) simp

lemma negligible_0 [negligible_intros, simp, intro!]: "negligible 0"
by(simp add: zero_fun_def)

lemma negligible_const_iff [simp]: "negligible (\<lambda>_. c :: real) \<longleftrightarrow> c = 0"
by(auto simp add: negligible_def const_smallo_inverse_powr filterlim_real_sequentially dest!: spec[where x=1])

lemma not_negligible_1: "\<not> negligible (\<lambda>_. 1 :: real)"
by simp

lemma negligible_plus [negligible_intros]:
  "\<lbrakk> negligible f; negligible g \<rbrakk> \<Longrightarrow> negligible (\<lambda>\<eta>. f \<eta> + g \<eta>)"
by(auto intro!: negligibleI dest!: negligibleD intro: sum_in_smallo)

lemma negligible_uminus [simp]: "negligible (\<lambda>\<eta>. - f \<eta>) \<longleftrightarrow> negligible f"
by(simp add: negligible_def)

lemma negligible_uminusI [negligible_intros]: "negligible f \<Longrightarrow> negligible (\<lambda>\<eta>. - f \<eta>)"
by simp

lemma negligible_minus [negligible_intros]:
  "\<lbrakk> negligible f; negligible g \<rbrakk> \<Longrightarrow> negligible (\<lambda>\<eta>. f \<eta> - g \<eta>)"
by(auto simp add: uminus_add_conv_diff[symmetric] negligible_plus simp del: uminus_add_conv_diff)

lemma negligible_cmult: "negligible (\<lambda>\<eta>. c * f \<eta>) \<longleftrightarrow> negligible f \<or> c = 0"
by(auto intro!: negligibleI dest!: negligibleD)

lemma negligible_cmultI [negligible_intros]:
  "(c \<noteq> 0 \<Longrightarrow> negligible f) \<Longrightarrow> negligible (\<lambda>\<eta>. c * f \<eta>)"
by(auto simp add: negligible_cmult)

lemma negligible_multc: "negligible (\<lambda>\<eta>. f \<eta> * c) \<longleftrightarrow> negligible f \<or> c = 0"
by(subst mult.commute)(simp add: negligible_cmult)

lemma negligible_multcI [negligible_intros]:
  "(c \<noteq> 0 \<Longrightarrow> negligible f) \<Longrightarrow> negligible (\<lambda>\<eta>. f \<eta> * c)"
by(auto simp add: negligible_multc)

lemma negligible_times [negligible_intros]:
  assumes f: "negligible f"
  and g: "negligible g"
  shows "negligible (\<lambda>\<eta>. f \<eta> * g \<eta> :: real)"
proof
  fix c :: real
  assume "0 < c"
  hence "0 < c / 2" by simp
  from negligibleD[OF f this] negligibleD[OF g this]
  have "(\<lambda>\<eta>. f \<eta> * g \<eta>) \<in> o(\<lambda>x. inverse (x powr (c / 2)) * inverse (x powr (c / 2)))"
    by(rule landau_o.small_mult)
  also have "\<dots> = o(\<lambda>x. inverse (x powr c))"
    by(rule landau_o.small.cong)(auto simp add: inverse_mult_distrib[symmetric] powr_add[symmetric] eventually_at_top_linorder intro!: exI[where x=1] simp del: inverse_mult_distrib)
  finally show "(\<lambda>\<eta>. f \<eta> * g \<eta>) \<in> \<dots>" .
qed

lemma negligible_power [negligible_intros]:
  assumes "negligible f"
  and "n > 0"
  shows "negligible (\<lambda>\<eta>. f \<eta> ^ n :: real)"
using \<open>n > 0\<close>
proof(induct n)
  case (Suc n)
  thus ?case using \<open>negligible f\<close> by(cases n)(simp_all add: negligible_times)
qed simp

lemma negligible_powr [negligible_intros]:
  assumes f: "negligible f"
  and p: "p > 0"
  shows "negligible (\<lambda>x. \<bar>f x\<bar> powr p :: real)"
proof
  fix c :: real
  let ?c = "c / p"
  assume c: "0 < c"
  with p have "0 < ?c" by simp
  with f have "f \<in> o(\<lambda>x. inverse (x powr ?c))" by(rule negligibleD)
  hence "(\<lambda>x. \<bar>f x\<bar> powr p) \<in> o(\<lambda>x. \<bar>inverse (x powr ?c)\<bar> powr p)" using p by(rule smallo_powr)
  also have "\<dots> = o(\<lambda>x. inverse (x powr c))"
    apply(rule landau_o.small.cong) using p by(auto simp add: powr_powr)
  finally show "(\<lambda>x. \<bar>f x\<bar> powr p) \<in> \<dots>" .
qed

lemma negligible_abs [simp]: "negligible (\<lambda>x. \<bar>f x\<bar>) \<longleftrightarrow> negligible f"
by(simp add: negligible_def)

lemma negligible_absI [negligible_intros]: "negligible f \<Longrightarrow> negligible (\<lambda>x. \<bar>f x\<bar>)"
by(simp)

lemma negligible_powrI [negligible_intros]:
  assumes "0 \<le> k" "k < 1"
  shows "negligible (\<lambda>x. k powr x)"
proof(cases "k = 0")
  case True
  thus ?thesis by simp
next
  case False
  show ?thesis
  proof
    fix c :: real
    assume "0 < c"
    then have "(\<lambda>x. real x powr c) \<in> o(\<lambda>x. inverse k powr real x)" using assms False
      by(intro powr_fast_growth_tendsto)(simp_all add: one_less_inverse_iff filterlim_real_sequentially)
    then have "(\<lambda>x. inverse (k powr - real x)) \<in> o(\<lambda>x. inverse (real x powr c))" using assms
      by(intro landau_o.small.inverse)(auto simp add: False eventually_sequentially powr_minus intro: exI[where x=1])
    also have "(\<lambda>x. inverse (k powr - real x)) = (\<lambda>x. k powr real x)" by(simp add: powr_minus)
    finally show "\<dots> \<in> o(\<lambda>x. inverse (x powr c))" .
  qed
qed

lemma negligible_powerI [negligible_intros]:
  fixes k :: real
  assumes "\<bar>k\<bar> < 1"
  shows "negligible (\<lambda>n. k ^ n)"
proof(cases "k = 0")
  case True
  show ?thesis using negligible_K0
    by(rule negligible_mono)(auto intro: exI[where x=1] simp add: True eventually_at_top_linorder)
next
  case False
  hence "0 < \<bar>k\<bar>" by auto
  from assms have "negligible (\<lambda>x. \<bar>k\<bar> powr real x)" using negligible_powrI[of "\<bar>k\<bar>"] by simp
  hence "negligible (\<lambda>x. \<bar>k\<bar> ^ x)" using False
    by(elim negligible_mono)(simp add: powr_realpow)
  then show ?thesis by(simp add: power_abs[symmetric])
qed

lemma negligible_inverse_powerI [negligible_intros]: "\<bar>k\<bar> > 1 \<Longrightarrow> negligible (\<lambda>\<eta>. 1 / k ^ \<eta>)"
using negligible_powerI[of "1 / k"] by(simp add: power_one_over)

inductive polynomial :: "(nat \<Rightarrow> real) \<Rightarrow> bool"
  for f
where "f \<in> O(\<lambda>x. x powr n) \<Longrightarrow> polynomial f"

lemma negligible_poly_times:
  "\<lbrakk> f \<in> O(\<lambda>x. x powr n); negligible g \<rbrakk> \<Longrightarrow> negligible (\<lambda>x. f x * g x)"
by(subst mult.commute)(rule negligible_times_poly)

lemma negligible_times_polynomial [negligible_intros]:
  "\<lbrakk> negligible f; polynomial g \<rbrakk> \<Longrightarrow> negligible (\<lambda>x. f x * g x)"
by(clarsimp simp add: polynomial.simps negligible_times_poly)

lemma negligible_polynomial_times [negligible_intros]:
  "\<lbrakk> polynomial f; negligible g \<rbrakk> \<Longrightarrow> negligible (\<lambda>x. f x * g x)"
by(clarsimp simp add: polynomial.simps negligible_poly_times)

lemma negligible_divide_poly1:
  "\<lbrakk> f \<in> O(\<lambda>x. x powr n); negligible (\<lambda>\<eta>. 1 / g \<eta>) \<rbrakk> \<Longrightarrow> negligible (\<lambda>\<eta>. real (f \<eta>) / g \<eta>)"
by(drule (1) negligible_times_poly) simp

lemma negligible_divide_polynomial1 [negligible_intros]:
  "\<lbrakk> polynomial f; negligible (\<lambda>\<eta>. 1 / g \<eta>) \<rbrakk> \<Longrightarrow> negligible (\<lambda>\<eta>. real (f \<eta>) / g \<eta>)"
by(clarsimp simp add: polynomial.simps negligible_divide_poly1)

end


section \<open>List Insertion and Deletion\<close>

theory List_Ins_Del
imports Sorted_Less
begin

subsection \<open>Elements in a list\<close>

lemma sorted_Cons_iff:
  "sorted(x # xs) = ((\<forall>y \<in> set xs. x < y) \<and> sorted xs)"
by(simp add: sorted_wrt_Cons)

lemma sorted_snoc_iff:
  "sorted(xs @ [x]) = (sorted xs \<and> (\<forall>y \<in> set xs. y < x))"
by(simp add: sorted_wrt_append)

lemmas isin_simps = sorted_mid_iff' sorted_Cons_iff sorted_snoc_iff

subsection \<open>Inserting into an ordered list without duplicates:\<close>

fun ins_list :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"ins_list x [] = [x]" |
"ins_list x (a#xs) =
  (if x < a then x#a#xs else if x=a then a#xs else a # ins_list x xs)"

lemma set_ins_list: "set (ins_list x xs) = set xs \<union> {x}"
by(induction xs) auto

lemma sorted_ins_list: "sorted xs \<Longrightarrow> sorted(ins_list x xs)"
by(induction xs rule: induct_list012) auto

lemma ins_list_sorted: "sorted (xs @ [a]) \<Longrightarrow>
  ins_list x (xs @ a # ys) =
  (if x < a then ins_list x xs @ (a#ys) else xs @ ins_list x (a#ys))"
by(induction xs) (auto simp: sorted_lems)

text\<open>In principle, @{thm ins_list_sorted} suffices, but the following two
corollaries speed up proofs.\<close>

corollary ins_list_sorted1: "sorted (xs @ [a]) \<Longrightarrow> a \<le> x \<Longrightarrow>
  ins_list x (xs @ a # ys) = xs @ ins_list x (a#ys)"
by(auto simp add: ins_list_sorted)

corollary ins_list_sorted2: "sorted (xs @ [a]) \<Longrightarrow> x < a \<Longrightarrow>
  ins_list x (xs @ a # ys) = ins_list x xs @ (a#ys)"
by(auto simp: ins_list_sorted)

lemmas ins_list_simps = sorted_lems ins_list_sorted1 ins_list_sorted2

text\<open>Splay trees need two additional \<^const>\<open>ins_list\<close> lemmas:\<close>

lemma ins_list_Cons: "sorted (x # xs) \<Longrightarrow> ins_list x xs = x # xs"
by (induction xs) auto

lemma ins_list_snoc: "sorted (xs @ [x]) \<Longrightarrow> ins_list x xs = xs @ [x]"
by(induction xs) (auto simp add: sorted_mid_iff2)

subsection \<open>Delete one occurrence of an element from a list:\<close>

fun del_list :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"del_list x [] = []" |
"del_list x (a#xs) = (if x=a then xs else a # del_list x xs)"

lemma del_list_idem: "x \<notin> set xs \<Longrightarrow> del_list x xs = xs"
by (induct xs) simp_all

lemma set_del_list:
  "sorted xs \<Longrightarrow> set (del_list x xs) = set xs - {x}"
by(induct xs) (auto simp: sorted_Cons_iff)

lemma sorted_del_list: "sorted xs \<Longrightarrow> sorted(del_list x xs)"
apply(induction xs rule: induct_list012)
apply auto
by (meson order.strict_trans sorted_Cons_iff)

lemma del_list_sorted: "sorted (xs @ a # ys) \<Longrightarrow>
  del_list x (xs @ a # ys) = (if x < a then del_list x xs @ a # ys else xs @ del_list x (a # ys))"
by(induction xs)
  (fastforce simp: sorted_lems sorted_Cons_iff intro!: del_list_idem)+

text\<open>In principle, @{thm del_list_sorted} suffices, but the following
corollaries speed up proofs.\<close>

corollary del_list_sorted1: "sorted (xs @ a # ys) \<Longrightarrow> a \<le> x \<Longrightarrow>
  del_list x (xs @ a # ys) = xs @ del_list x (a # ys)"
by (auto simp: del_list_sorted)

corollary del_list_sorted2: "sorted (xs @ a # ys) \<Longrightarrow> x < a \<Longrightarrow>
  del_list x (xs @ a # ys) = del_list x xs @ a # ys"
by (auto simp: del_list_sorted)

corollary del_list_sorted3:
  "sorted (xs @ a # ys @ b # zs) \<Longrightarrow> x < b \<Longrightarrow>
  del_list x (xs @ a # ys @ b # zs) = del_list x (xs @ a # ys) @ b # zs"
by (auto simp: del_list_sorted sorted_lems)

corollary del_list_sorted4:
  "sorted (xs @ a # ys @ b # zs @ c # us) \<Longrightarrow> x < c \<Longrightarrow>
  del_list x (xs @ a # ys @ b # zs @ c # us) = del_list x (xs @ a # ys @ b # zs) @ c # us"
by (auto simp: del_list_sorted sorted_lems)

corollary del_list_sorted5:
  "sorted (xs @ a # ys @ b # zs @ c # us @ d # vs) \<Longrightarrow> x < d \<Longrightarrow>
   del_list x (xs @ a # ys @ b # zs @ c # us @ d # vs) =
   del_list x (xs @ a # ys @ b # zs @ c # us) @ d # vs"
by (auto simp: del_list_sorted sorted_lems)

lemmas del_list_simps = sorted_lems
  del_list_sorted1
  del_list_sorted2
  del_list_sorted3
  del_list_sorted4
  del_list_sorted5

text\<open>Splay trees need two additional \<^const>\<open>del_list\<close> lemmas:\<close>

lemma del_list_notin_Cons: "sorted (x # xs) \<Longrightarrow> del_list x xs = xs"
by(induction xs)(fastforce simp: sorted_Cons_iff)+

lemma del_list_sorted_app:
  "sorted(xs @ [x]) \<Longrightarrow> del_list x (xs @ ys) = xs @ del_list x ys"
by (induction xs) (auto simp: sorted_mid_iff2)

end


theory Szip_iterates
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")
datatype ('a, 'b) Pair2 = Pair2 'a 'b
primcorec szip :: "'a Stream \<Rightarrow> 'b Stream \<Rightarrow> (('a, 'b) Pair2) Stream" where
  "shd (szip s1 s2) = Pair2 (shd s1) (shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "shd (siterate f x) = x"
| "stl (siterate f x) = siterate f (f x)"

fun map_prod2 :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a,'b) Pair2 \<Rightarrow> ('c,'d) Pair2" where
"map_prod2 f g (Pair2 a b) = Pair2 (f a) (g b)"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

hipster_obs Stream Lst obsStream szip siterate map_prod2
(*  Proving: map_prod2 z z (Pair22 y x2) = Pair22 (z y) (z x2) *)

theorem szip_iterates:
  "szip (siterate f a) (siterate g b) = siterate (map_prod2 f g) (Pair2 a b)"
  by hipster_coinduct_sledgehammer
end


section \<open> Multiplication Groups \<close>

theory Groups_mult
  imports Main
begin

text \<open> The HOL standard library only has groups based on addition. Here, we build one based on
  multiplication. \<close>

notation times (infixl "\<cdot>" 70)

class group_mult = inverse + monoid_mult +
  assumes left_inverse: "inverse a \<cdot> a = 1"
  assumes multi_inverse_conv_div [simp]: "a \<cdot> (inverse b) = a / b"
begin

lemma div_conv_mult_inverse: "a / b = a \<cdot> (inverse b)"
  by simp

sublocale mult: group times 1 inverse
  by standard (simp_all add: left_inverse)

lemma diff_self [simp]: "a / a = 1"
  using mult.right_inverse by auto

lemma mult_distrib_inverse [simp]: "(a * b) / b = a"
  by (metis local.mult_1_right local.multi_inverse_conv_div mult.right_inverse mult_assoc)

end

class ab_group_mult = comm_monoid_mult + group_mult
begin

lemma mult_distrib_inverse' [simp]: "(a * b) / a = b"
  using local.mult_distrib_inverse mult_commute by fastforce

lemma inverse_distrib: "inverse (a * b)  =  (inverse a) * (inverse b)"
  by (simp add: local.mult.inverse_distrib_swap mult_commute)

lemma inverse_divide [simp]: "inverse (a / b) = b / a"
  by (metis div_conv_mult_inverse inverse_distrib mult.commute mult.inverse_inverse)

end

abbreviation (input) npower :: "'a::{power,inverse} \<Rightarrow> nat \<Rightarrow> 'a"  ("(_\<^sup>-\<^sup>_)" [1000,999] 999)
  where "npower x n \<equiv> inverse (x ^ n)"

end


(*  Title:      HOL/Cardinals/Cardinal_Arithmetic.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Copyright   2012

Cardinal arithmetic.
*)

section \<open>Cardinal Arithmetic\<close>

theory Cardinal_Arithmetic
imports Cardinal_Order_Relation
begin

subsection \<open>Binary sum\<close>

lemma csum_Cnotzero2:
  "Cnotzero r2 \<Longrightarrow> Cnotzero (r1 +c r2)"
unfolding csum_def
by (metis Cnotzero_imp_not_empty Field_card_of Plus_eq_empty_conv card_of_card_order_on czeroE)

lemma single_cone:
  "|{x}| =o cone"
proof -
  let ?f = "\<lambda>x. ()"
  have "bij_betw ?f {x} {()}" unfolding bij_betw_def by auto
  thus ?thesis unfolding cone_def using card_of_ordIso by blast
qed

lemma cone_Cnotzero: "Cnotzero cone"
by (simp add: cone_not_czero Card_order_cone)

lemma cone_ordLeq_ctwo: "cone \<le>o ctwo"
unfolding cone_def ctwo_def card_of_ordLeq[symmetric] by auto

lemma csum_czero1: "Card_order r \<Longrightarrow> r +c czero =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty1] card_of_Field_ordIso])

lemma csum_czero2: "Card_order r \<Longrightarrow> czero +c r =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty2] card_of_Field_ordIso])

subsection \<open>Product\<close>

lemma Times_cprod: "|A \<times> B| =o |A| *c |B|"
by (simp only: cprod_def Field_card_of card_of_refl)

lemma card_of_Times_singleton:
  fixes A :: "'a set"
  shows "|A \<times> {x}| =o |A|"
proof -
  define f :: "'a \<times> 'b \<Rightarrow> 'a" where "f = (\<lambda>(a, b). a)"
  have "A \<subseteq> f ` (A \<times> {x})" unfolding f_def by (auto simp: image_iff)
  hence "bij_betw f (A \<times> {x}) A"  unfolding bij_betw_def inj_on_def f_def by fastforce
  thus ?thesis using card_of_ordIso by blast
qed

lemma cprod_assoc: "(r *c s) *c t =o r *c s *c t"
  unfolding cprod_def Field_card_of by (rule card_of_Times_assoc)

lemma cprod_czero: "r *c czero =o czero"
  unfolding cprod_def czero_def Field_card_of by (simp add: card_of_empty_ordIso)

lemma cprod_cone: "Card_order r \<Longrightarrow> r *c cone =o r"
  unfolding cprod_def cone_def Field_card_of
  by (drule card_of_Field_ordIso) (erule ordIso_transitive[OF card_of_Times_singleton])

lemma ordLeq_cprod1: "\<lbrakk>Card_order p1; Cnotzero p2\<rbrakk> \<Longrightarrow> p1 \<le>o p1 *c p2"
unfolding cprod_def by (metis Card_order_Times1 czeroI)

subsection \<open>Exponentiation\<close>

lemma cexp_czero: "r ^c czero =o cone"
unfolding cexp_def czero_def Field_card_of Func_empty by (rule single_cone)

lemma Pow_cexp_ctwo:
  "|Pow A| =o ctwo ^c |A|"
unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)

lemma Cnotzero_cexp:
  assumes "Cnotzero q"
  shows "Cnotzero (q ^c r)"
proof -
  have "Field q \<noteq> {}"
    by (metis Card_order_iff_ordIso_card_of assms(1) czero_def)
  then show ?thesis
    by (simp add: card_of_ordIso_czero_iff_empty cexp_def)
qed

lemma Cinfinite_ctwo_cexp:
  "Cinfinite r \<Longrightarrow> Cinfinite (ctwo ^c r)"
unfolding ctwo_def cexp_def cinfinite_def Field_card_of
by (rule conjI, rule infinite_Func, auto)

lemma cone_ordLeq_iff_Field:
  assumes "cone \<le>o r"
  shows "Field r \<noteq> {}"
proof (rule ccontr)
  assume "\<not> Field r \<noteq> {}"
  hence "Field r = {}" by simp
  thus False using card_of_empty3
    card_of_mono2[OF assms] Cnotzero_imp_not_empty[OF cone_Cnotzero] by auto
qed

lemma cone_ordLeq_cexp: "cone \<le>o r1 \<Longrightarrow> cone \<le>o r1 ^c r2"
by (simp add: cexp_def cone_def Func_non_emp cone_ordLeq_iff_Field)

lemma Card_order_czero: "Card_order czero"
by (simp only: card_of_Card_order czero_def)

lemma cexp_mono2'':
  assumes 2: "p2 \<le>o r2"
  and n1: "Cnotzero q"
  and n2: "Card_order p2"
  shows "q ^c p2 \<le>o q ^c r2"
proof (cases "p2 =o (czero :: 'a rel)")
  case True
  hence "q ^c p2 =o q ^c (czero :: 'a rel)" using n1 n2 cexp_cong2 Card_order_czero by blast
  also have "q ^c (czero :: 'a rel) =o cone" using cexp_czero by blast
  also have "cone \<le>o q ^c r2" using cone_ordLeq_cexp cone_ordLeq_Cnotzero n1 by blast
  finally show ?thesis .
next
  case False thus ?thesis using assms cexp_mono2' czeroI by metis
qed

lemma csum_cexp: "\<lbrakk>Cinfinite r1; Cinfinite r2; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow>
  q ^c r1 +c q ^c r2 \<le>o q ^c (r1 +c r2)"
  apply (rule csum_cinfinite_bound)
  apply (metis cexp_mono2' cinfinite_def finite.emptyI ordLeq_csum1)
  apply (metis cexp_mono2' cinfinite_def finite.emptyI ordLeq_csum2)
  by (simp_all add: Card_order_cexp Cinfinite_csum1 Cinfinite_cexp cinfinite_cexp)

lemma csum_cexp': "\<lbrakk>Cinfinite r; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow> q +c r \<le>o q ^c r"
apply (rule csum_cinfinite_bound)
    apply (metis Cinfinite_Cnotzero ordLeq_cexp1)
   apply (metis ordLeq_cexp2)
  apply blast+
by (metis Cinfinite_cexp)

lemma card_of_Sigma_ordLeq_Cinfinite:
  "\<lbrakk>Cinfinite r; |I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r\<rbrakk> \<Longrightarrow> |SIGMA i : I. A i| \<le>o r"
unfolding cinfinite_def by (blast intro: card_of_Sigma_ordLeq_infinite_Field)

lemma card_order_cexp:
  assumes "card_order r1" "card_order r2"
  shows "card_order (r1 ^c r2)"
proof -
  have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
  thus ?thesis unfolding cexp_def Func_def by simp
qed

lemma Cinfinite_ordLess_cexp:
  assumes r: "Cinfinite r"
  shows "r <o r ^c r"
proof -
  have "r <o ctwo ^c r" using r by (simp only: ordLess_ctwo_cexp)
  also have "ctwo ^c r \<le>o r ^c r"
    by (rule cexp_mono1[OF ctwo_ordLeq_Cinfinite]) (auto simp: r ctwo_not_czero Card_order_ctwo)
  finally show ?thesis .
qed

lemma infinite_ordLeq_cexp:
  assumes "Cinfinite r"
  shows "r \<le>o r ^c r"
by (rule ordLess_imp_ordLeq[OF Cinfinite_ordLess_cexp[OF assms]])

lemma czero_cexp: "Cnotzero r \<Longrightarrow> czero ^c r =o czero"
  by (drule Cnotzero_imp_not_empty) (simp add: cexp_def czero_def card_of_empty_ordIso)

lemma Func_singleton:
fixes x :: 'b and A :: "'a set"
shows "|Func A {x}| =o |{x}|"
proof (rule ordIso_symmetric)
  define f where [abs_def]: "f y a = (if y = x \<and> a \<in> A then x else undefined)" for y a
  have "Func A {x} \<subseteq> f ` {x}" unfolding f_def Func_def by (force simp: fun_eq_iff)
  hence "bij_betw f {x} (Func A {x})" unfolding bij_betw_def inj_on_def f_def Func_def
    by (auto split: if_split_asm)
  thus "|{x}| =o |Func A {x}|" using card_of_ordIso by blast
qed

lemma cone_cexp: "cone ^c r =o cone"
  unfolding cexp_def cone_def Field_card_of by (rule Func_singleton)

lemma card_of_Func_squared:
  fixes A :: "'a set"
  shows "|Func (UNIV :: bool set) A| =o |A \<times> A|"
proof (rule ordIso_symmetric)
  define f where "f = (\<lambda>(x::'a,y) b. if A = {} then undefined else if b then x else y)"
  have "Func (UNIV :: bool set) A \<subseteq> f ` (A \<times> A)" unfolding f_def Func_def
    by (auto simp: image_iff fun_eq_iff split: option.splits if_split_asm) blast
  hence "bij_betw f (A \<times> A) (Func (UNIV :: bool set) A)"
    unfolding bij_betw_def inj_on_def f_def Func_def by (auto simp: fun_eq_iff)
  thus "|A \<times> A| =o |Func (UNIV :: bool set) A|" using card_of_ordIso by blast
qed

lemma cexp_ctwo: "r ^c ctwo =o r *c r"
  unfolding cexp_def ctwo_def cprod_def Field_card_of by (rule card_of_Func_squared)

lemma card_of_Func_Plus:
  fixes A :: "'a set" and B :: "'b set" and C :: "'c set"
  shows "|Func (A <+> B) C| =o |Func A C \<times> Func B C|"
proof (rule ordIso_symmetric)
  define f where "f = (\<lambda>(g :: 'a => 'c, h::'b \<Rightarrow> 'c) ab. case ab of Inl a \<Rightarrow> g a | Inr b \<Rightarrow> h b)"
  define f' where "f' = (\<lambda>(f :: ('a + 'b) \<Rightarrow> 'c). (\<lambda>a. f (Inl a), \<lambda>b. f (Inr b)))"
  have "f ` (Func A C \<times> Func B C) \<subseteq> Func (A <+> B) C"
    unfolding Func_def f_def by (force split: sum.splits)
  moreover have "f' ` Func (A <+> B) C \<subseteq> Func A C \<times> Func B C" unfolding Func_def f'_def by force
  moreover have "\<forall>a \<in> Func A C \<times> Func B C. f' (f a) = a" unfolding f'_def f_def Func_def by auto
  moreover have "\<forall>a' \<in> Func (A <+> B) C. f (f' a') = a'" unfolding f'_def f_def Func_def
    by (auto split: sum.splits)
  ultimately have "bij_betw f (Func A C \<times> Func B C) (Func (A <+> B) C)"
    by (intro bij_betw_byWitness[of _ f' f])
  thus "|Func A C \<times> Func B C| =o |Func (A <+> B) C|" using card_of_ordIso by blast
qed

lemma cexp_csum: "r ^c (s +c t) =o r ^c s *c r ^c t"
  unfolding cexp_def cprod_def csum_def Field_card_of by (rule card_of_Func_Plus)

subsection \<open>Powerset\<close>

definition cpow where "cpow r = |Pow (Field r)|"

lemma card_order_cpow: "card_order r \<Longrightarrow> card_order (cpow r)"
by (simp only: cpow_def Field_card_order Pow_UNIV card_of_card_order_on)

lemma cpow_greater_eq: "Card_order r \<Longrightarrow> r \<le>o cpow r"
by (rule ordLess_imp_ordLeq) (simp only: cpow_def Card_order_Pow)

lemma Cinfinite_cpow: "Cinfinite r \<Longrightarrow> Cinfinite (cpow r)"
unfolding cpow_def cinfinite_def by (metis Field_card_of card_of_Card_order infinite_Pow)

lemma Card_order_cpow: "Card_order (cpow r)"
unfolding cpow_def by (rule card_of_Card_order)

lemma cardSuc_ordLeq_cpow: "Card_order r \<Longrightarrow> cardSuc r \<le>o cpow r"
unfolding cpow_def by (metis Card_order_Pow cardSuc_ordLess_ordLeq card_of_Card_order)

lemma cpow_cexp_ctwo: "cpow r =o ctwo ^c r"
unfolding cpow_def ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)

subsection \<open>Inverse image\<close>

lemma vimage_ordLeq:
assumes "|A| \<le>o k" and "\<forall> a \<in> A. |vimage f {a}| \<le>o k" and "Cinfinite k"
shows "|vimage f A| \<le>o k"
proof-
  have "vimage f A = (\<Union>a \<in> A. vimage f {a})" by auto
  also have "|\<Union>a \<in> A. vimage f {a}| \<le>o k"
  using UNION_Cinfinite_bound[OF assms] .
  finally show ?thesis .
qed

subsection \<open>Maximum\<close>

definition cmax where
  "cmax r s =
    (if cinfinite r \<or> cinfinite s then czero +c r +c s
     else natLeq_on (max (card (Field r)) (card (Field s))) +c czero)"

lemma cmax_com: "cmax r s =o cmax s r"
  unfolding cmax_def
  by (auto simp: max.commute intro: csum_cong2[OF csum_com] csum_cong2[OF czero_ordIso])

lemma cmax1:
  assumes "Card_order r" "Card_order s" "s \<le>o r"
  shows "cmax r s =o r"
unfolding cmax_def proof (split if_splits, intro conjI impI)
  assume "cinfinite r \<or> cinfinite s"
  hence Cinf: "Cinfinite r" using assms(1,3) by (metis cinfinite_mono)
  have "czero +c r +c s =o r +c s" by (rule csum_czero2[OF Card_order_csum])
  also have "r +c s =o r" by (rule csum_absorb1[OF Cinf assms(3)])
  finally show "czero +c r +c s =o r" .
next
  assume "\<not> (cinfinite r \<or> cinfinite s)"
  hence fin: "finite (Field r)" and "finite (Field s)" unfolding cinfinite_def by simp_all
  moreover
  { from assms(2) have "|Field s| =o s" by (rule card_of_Field_ordIso)
    also from assms(3) have "s \<le>o r" .
    also from assms(1) have "r =o |Field r|" by (rule ordIso_symmetric[OF card_of_Field_ordIso])
    finally have "|Field s| \<le>o |Field r|" .
  }
  ultimately have "card (Field s) \<le> card (Field r)" by (subst sym[OF finite_card_of_iff_card2])
  hence "max (card (Field r)) (card (Field s)) = card (Field r)" by (rule max_absorb1)
  hence "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =
    natLeq_on (card (Field r)) +c czero" by simp
  also have "\<dots> =o natLeq_on (card (Field r))" by (rule csum_czero1[OF natLeq_on_Card_order])
  also have "natLeq_on (card (Field r)) =o |Field r|"
    by (rule ordIso_symmetric[OF finite_imp_card_of_natLeq_on[OF fin]])
  also from assms(1) have "|Field r| =o r" by (rule card_of_Field_ordIso)
  finally show "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =o r" .
qed

lemma cmax2:
  assumes "Card_order r" "Card_order s" "r \<le>o s"
  shows "cmax r s =o s"
  by (metis assms cmax1 cmax_com ordIso_transitive)

lemma csum_absorb2: "Cinfinite r2 \<Longrightarrow> r1 \<le>o r2 \<Longrightarrow> r1 +c r2 =o r2"
  by (metis csum_absorb2')

lemma cprod_infinite2': "\<lbrakk>Cnotzero r1; Cinfinite r2; r1 \<le>o r2\<rbrakk> \<Longrightarrow> r1 *c r2 =o r2"
  unfolding ordIso_iff_ordLeq
  by (intro conjI cprod_cinfinite_bound ordLeq_cprod2 ordLeq_refl)
    (auto dest!: ordIso_imp_ordLeq not_ordLeq_ordLess simp: czero_def Card_order_empty)

context
  fixes r s
  assumes r: "Cinfinite r"
  and     s: "Cinfinite s"
begin

lemma cmax_csum: "cmax r s =o r +c s"
proof (cases "r \<le>o s")
  case True
  hence "cmax r s =o s" by (metis cmax2 r s)
  also have "s =o r +c s" by (metis True csum_absorb2 ordIso_symmetric s)
  finally show ?thesis .
next
  case False
  hence "s \<le>o r" by (metis ordLeq_total r s card_order_on_def)
  hence "cmax r s =o r" by (metis cmax1 r s)
  also have "r =o r +c s" by (metis \<open>s \<le>o r\<close> csum_absorb1 ordIso_symmetric r)
  finally show ?thesis .
qed

lemma cmax_cprod: "cmax r s =o r *c s"
proof (cases "r \<le>o s")
  case True
  hence "cmax r s =o s" by (metis cmax2 r s)
  also have "s =o r *c s" by (metis Cinfinite_Cnotzero True cprod_infinite2' ordIso_symmetric r s)
  finally show ?thesis .
next
  case False
  hence "s \<le>o r" by (metis ordLeq_total r s card_order_on_def)
  hence "cmax r s =o r" by (metis cmax1 r s)
  also have "r =o r *c s" by (metis Cinfinite_Cnotzero \<open>s \<le>o r\<close> cprod_infinite1' ordIso_symmetric r s)
  finally show ?thesis .
qed

end

lemma Card_order_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "Card_order (cmax r s)"
unfolding cmax_def by (auto simp: Card_order_csum)

lemma ordLeq_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "r \<le>o cmax r s \<and> s \<le>o cmax r s"
proof-
  {assume "r \<le>o s"
   hence ?thesis by (metis cmax2 ordIso_iff_ordLeq ordLeq_transitive r s)
  }
  moreover
  {assume "s \<le>o r"
   hence ?thesis using cmax_com by (metis cmax2 ordIso_iff_ordLeq ordLeq_transitive r s)
  }
  ultimately show ?thesis using r s ordLeq_total unfolding card_order_on_def by auto
qed

lemmas ordLeq_cmax1 = ordLeq_cmax[THEN conjunct1] and
       ordLeq_cmax2 = ordLeq_cmax[THEN conjunct2]

lemma finite_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "finite (Field (cmax r s)) \<longleftrightarrow> finite (Field r) \<and> finite (Field s)"
proof-
  {assume "r \<le>o s"
   hence ?thesis by (metis cmax2 ordIso_finite_Field ordLeq_finite_Field r s)
  }
  moreover
  {assume "s \<le>o r"
   hence ?thesis by (metis cmax1 ordIso_finite_Field ordLeq_finite_Field r s)
  }
  ultimately show ?thesis using r s ordLeq_total unfolding card_order_on_def by auto
qed

end


theory ex01
imports Main
begin

value "2 + (2::nat)"

value "(2::nat) * (5 + 3)"

value "(3::nat) * 4 - 2 *(7 + 1)"

lemma "(x::nat) + (y + z) = (x + y) + z"
  by auto

lemma "(x::nat) + y = y + x"
  apply auto
  done

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0" |
  "count (x#xs) x' = (if x = x' then Suc (count xs x') else count xs x')"

value "count [(1::nat), 1, 1] 1"

theorem "count xs x \<le> length xs"
  apply(induct xs)
   apply auto
  done

fun snoc::"'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] x' = [x']" |
"snoc (x#xs) x' = x # (snoc xs x')"

value "snoc [(1::nat),2,3,4] 5"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x#xs) = snoc (reverse xs) x"

value "reverse [(1::nat),2,3,4]"

lemma "reverse [(1::nat),2,3,4] = [4,3,2,1]"
  by simp

lemma reverse_snoc:
  "reverse (snoc xs y) = y # reverse xs"
  by (induct xs) auto

theorem "reverse (reverse xs) = xs"
  apply(induct xs)
   apply (auto simp add: reverse_snoc)
  done

end