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

declare cis_pi[simp]

lemma cis_pi_2[simp]: "cis (pi / 2) = \<i>"
  by (auto simp: complex_eq_iff)

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 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 arg_unique[OF sgn_cis assms(2-3)] 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


(* License: LGPL *)

section \<open>Arg Min and Arg Max sets\<close>

theory Argmax
  imports
    "Complex_Main"
begin

subsection \<open> Definitions and Lemmas by Julian Parsert \<close>

text \<open> definition of argmax and argmin returing a set. \<close>

definition arg_min_set :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where
    "arg_min_set f S = {x. is_arg_min f (\<lambda>x. x\<in>S) x}"

definition arg_max_set :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where
    "arg_max_set f S = {x. is_arg_max f (\<lambda>x. x\<in>S) x}"

text \<open> Useful lemmas for @{term "arg_max_set"} and @{term "arg_min_set"}. \<close>

lemma no_better_in_s:
  assumes "x \<in> arg_max_set f S"
  shows "\<nexists>y. y \<in> S \<and> (f y) > (f x)"
  by (metis arg_max_set_def assms is_arg_max_def mem_Collect_eq)

lemma argmax_sol_in_s:
  assumes "x \<in> arg_max_set f S"
  shows "x \<in> S"
  by (metis CollectD arg_max_set_def assms is_arg_max_def)

lemma leq_all_in_sol:
  fixes f :: "'a \<Rightarrow> ('b :: preorder)"
  assumes "x \<in> arg_max_set f S"
  shows "\<forall>y \<in> S. f y \<ge> f x \<longrightarrow> y \<in> arg_max_set f S"
  using assms le_less_trans by (auto simp: arg_max_set_def is_arg_max_def)

lemma all_leq:
  fixes f :: "'a \<Rightarrow> ('b :: linorder)"
  assumes "x \<in> arg_max_set f S"
  shows "\<forall>y \<in> S. f x \<ge> f y"
  by (meson assms leI no_better_in_s)

lemma all_in_argmax_equal:
  fixes f :: "'a \<Rightarrow> ('b :: linorder)"
  assumes "x \<in> arg_max_set f S"
  shows "\<forall>y \<in> arg_max_set f S. f x = f y"
    by (meson all_leq argmax_sol_in_s assms le_less no_better_in_s)

end


chapter \<open>Case Study: Single and Multi-Mutator Garbage Collection Algorithms\<close>

section \<open>Formalization of the Memory\<close>

theory Graph imports MainRLT begin

datatype node = Black | White

type_synonym nodes = "node list"
type_synonym edge = "nat \<times> nat"
type_synonym edges = "edge list"

consts Roots :: "nat set"

definition Proper_Roots :: "nodes \<Rightarrow> bool" where
  "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"

definition Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool" where
  "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"

definition BtoW :: "(edge \<times> nodes) \<Rightarrow> bool" where
  "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"

definition Blacks :: "nodes \<Rightarrow> nat set" where
  "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"

definition Reach :: "edges \<Rightarrow> nat set" where
  "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
              \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
              \<or> x\<in>Roots}"

text\<open>Reach: the set of reachable nodes is the set of Roots together with the
nodes reachable from some Root by a path represented by a list of
  nodes (at least two since we traverse at least one edge), where two
consecutive nodes correspond to an edge in E.\<close>

subsection \<open>Proofs about Graphs\<close>

lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
declare Graph_defs [simp]

subsubsection\<open>Graph 1\<close>

lemma Graph1_aux [rule_format]:
  "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
  \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
  (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
  \<longrightarrow> M!(path!0) = Black"
apply(induct_tac "path")
 apply force
apply clarify
apply simp
apply(case_tac "list")
 apply force
apply simp
apply(rename_tac lista)
apply(rotate_tac -2)
apply(erule_tac x = "0" in all_dupE)
apply simp
apply clarify
apply(erule allE , erule (1) notE impE)
apply simp
apply(erule mp)
apply(case_tac "lista")
 apply force
apply simp
apply(erule mp)
apply clarify
apply(erule_tac x = "Suc i" in allE)
apply force
done

lemma Graph1:
  "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
  \<Longrightarrow> Reach E\<subseteq>Blacks M"
apply (unfold Reach_def)
apply simp
apply clarify
apply(erule disjE)
 apply clarify
 apply(rule conjI)
  apply(subgoal_tac "0< length path - Suc 0")
   apply(erule allE , erule (1) notE impE)
   apply force
  apply simp
 apply(rule Graph1_aux)
apply auto
done

subsubsection\<open>Graph 2\<close>

lemma Ex_first_occurrence [rule_format]:
  "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))"
apply(rule nat_less_induct)
apply clarify
apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
apply auto
done

lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
apply(rule_tac x = "l - n" in exI)
apply arith
done

lemma Ex_last_occurrence:
  "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
apply(drule Compl_lemma)
apply clarify
apply(erule Ex_first_occurrence)
done

lemma Graph2:
  "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
 apply(rule_tac x = "path" in exI)
 apply simp
 apply clarify
 apply(erule allE , erule (1) notE impE)
 apply clarify
 apply(rule_tac x = "j" in exI)
 apply(case_tac "j=R")
  apply(erule_tac x = "Suc i" in allE)
  apply simp
 apply (force simp add:nth_list_update)
apply simp
apply(erule exE)
apply(subgoal_tac "z \<le> length path - Suc 0")
 prefer 2 apply arith
apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
 apply assumption
apply clarify
apply simp
apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
apply simp
apply(case_tac "length path - (length path - Suc m)")
 apply arith
apply simp
apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
 prefer 2 apply arith
apply clarify
apply(case_tac "i")
 apply(force simp add: nth_list_update)
apply simp
apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
 prefer 2 apply arith
apply simp
apply(erule_tac x = "length path - Suc m + nata" in allE)
apply simp
apply clarify
apply(rule_tac x = "j" in exI)
apply(case_tac "R=j")
 prefer 2 apply force
apply simp
apply(drule_tac t = "path ! (length path - Suc m)" in sym)
apply simp
apply(case_tac " length path - Suc 0 < m")
 apply(subgoal_tac "(length path - Suc m)=0")
  prefer 2 apply arith
 apply(simp del: diff_is_0_eq)
 apply(subgoal_tac "Suc nata\<le>nat")
 prefer 2 apply arith
 apply(drule_tac n = "Suc nata" in Compl_lemma)
 apply clarify
 subgoal using [[linarith_split_limit = 0]] by force
apply(drule leI)
apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
 apply(erule_tac x = "m - (Suc nata)" in allE)
 apply(case_tac "m")
  apply simp
 apply simp
apply simp
done

subsubsection\<open>Graph 3\<close>

declare min.absorb1 [simp] min.absorb2 [simp]

lemma Graph3:
  "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
\<comment> \<open>the changed edge is part of the path\<close>
 apply(erule exE)
 apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
 apply clarify
 apply(erule disjE)
\<comment> \<open>T is NOT a root\<close>
  apply clarify
  apply(rule_tac x = "(take m path)@patha" in exI)
  apply(subgoal_tac "\<not>(length path\<le>m)")
   prefer 2 apply arith
  apply(simp)
  apply(rule conjI)
   apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
    prefer 2 apply arith
   apply(simp add: nth_append)
  apply(rule conjI)
   apply(case_tac "m")
    apply force
   apply(case_tac "path")
    apply force
   apply force
  apply clarify
  apply(case_tac "Suc i\<le>m")
   apply(erule_tac x = "i" in allE)
   apply simp
   apply clarify
   apply(rule_tac x = "j" in exI)
   apply(case_tac "Suc i<m")
    apply(simp add: nth_append)
    apply(case_tac "R=j")
     apply(simp add: nth_list_update)
     apply(case_tac "i=m")
      apply force
     apply(erule_tac x = "i" in allE)
     apply force
    apply(force simp add: nth_list_update)
   apply(simp add: nth_append)
   apply(subgoal_tac "i=m - 1")
    prefer 2 apply arith
   apply(case_tac "R=j")
    apply(erule_tac x = "m - 1" in allE)
    apply(simp add: nth_list_update)
   apply(force simp add: nth_list_update)
  apply(simp add: nth_append)
  apply(rotate_tac -4)
  apply(erule_tac x = "i - m" in allE)
  apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
    prefer 2 apply arith
   apply simp
\<comment> \<open>T is a root\<close>
 apply(case_tac "m=0")
  apply force
 apply(rule_tac x = "take (Suc m) path" in exI)
 apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
  prefer 2 apply arith
 apply clarsimp
 apply(erule_tac x = "i" in allE)
 apply simp
 apply clarify
 apply(case_tac "R=j")
  apply(force simp add: nth_list_update)
 apply(force simp add: nth_list_update)
\<comment> \<open>the changed edge is not part of the path\<close>
apply(rule_tac x = "path" in exI)
apply simp
apply clarify
apply(erule_tac x = "i" in allE)
apply clarify
apply(case_tac "R=j")
 apply(erule_tac x = "i" in allE)
 apply simp
apply(force simp add: nth_list_update)
done

subsubsection\<open>Graph 4\<close>

lemma Graph4:
  "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
  \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
  (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
\<comment> \<open>there exist a black node in the path to T\<close>
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply(case_tac "j<I")
  apply(erule_tac x = "j" in allE)
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

declare min.absorb1 [simp del] min.absorb2 [simp del]

subsubsection \<open>Graph 5\<close>

lemma Graph5:
  "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
    R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
   \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
\<comment> \<open>there exist a black node in the path to T\<close>
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply(case_tac "j\<le>R")
  apply(drule le_imp_less_or_eq [of _ R])
  apply(erule disjE)
   apply(erule allE , erule (1) notE impE)
   apply force
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

subsubsection \<open>Other lemmas about graphs\<close>

lemma Graph6:
 "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
apply (unfold Proper_Edges_def)
 apply(force  simp add: nth_list_update)
done

lemma Graph7:
 "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
apply (unfold Proper_Edges_def)
apply force
done

lemma Graph8:
 "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
apply (unfold Proper_Roots_def)
apply force
done

text\<open>Some specific lemmata for the verification of garbage collection algorithms.\<close>

lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
 apply(force simp add: nth_list_update)
done

lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
apply(induct_tac "M")
apply auto
apply(case_tac "i")
apply auto
done

lemma Graph11 [rule_format (no_asm)]:
  "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(rule psubsetI)
 apply(force simp add: nth_list_update)
apply safe
apply(erule_tac c = "j" in equalityCE)
apply auto
done

lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(force simp add: nth_list_update)
done

lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(erule psubset_subset_trans)
apply(force simp add: nth_list_update)
done

declare Graph_defs [simp del]

end


(*  Title:      HOL/Library/FSet.thy
    Author:     Ondrej Kuncar, TU Muenchen
    Author:     Cezary Kaliszyk and Christian Urban
    Author:     Andrei Popescu, TU Muenchen
*)

section \<open>Type of finite sets defined as a subtype of sets\<close>

theory FSet
imports Main
begin

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

typedef 'a fset = "{A :: 'a set. finite A}"  morphisms fset Abs_fset
by auto

setup_lifting type_definition_fset

subsection \<open>Basic operations and type class instantiations\<close>

(* FIXME transfer and right_total vs. bi_total *)
instantiation fset :: (finite) finite
begin
instance by (standard; transfer; simp)
end

instantiation fset :: (type) "{bounded_lattice_bot, distrib_lattice, minus}"
begin

lift_definition bot_fset :: "'a fset" is "{}" parametric empty_transfer by simp

lift_definition less_eq_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is subset_eq parametric subset_transfer
  .

definition less_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" where "xs < ys \<equiv> xs \<le> ys \<and> xs \<noteq> (ys::'a fset)"

lemma less_fset_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "((pcr_fset A) ===> (pcr_fset A) ===> op =) op \<subset> op <"
  unfolding less_fset_def[abs_def] psubset_eq[abs_def] by transfer_prover

lift_definition sup_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is union parametric union_transfer
  by simp

lift_definition inf_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is inter parametric inter_transfer
  by simp

lift_definition inf_fset2 :: "'a fset \<Rightarrow> 'a set \<Rightarrow> 'a fset" is inter parametric inter_transfer (* mhahn *)
  by simp

lift_definition minus_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is minus parametric Diff_transfer
  by simp

instance
  by (standard; transfer; auto)+

end

abbreviation fempty :: "'a fset" ("{||}") where "{||} \<equiv> bot"
abbreviation fsubset_eq :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subseteq>|" 50) where "xs |\<subseteq>| ys \<equiv> xs \<le> ys"
abbreviation fsubset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subset>|" 50) where "xs |\<subset>| ys \<equiv> xs < ys"
abbreviation funion :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<union>|" 65) where "xs |\<union>| ys \<equiv> sup xs ys"
abbreviation finter :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<inter>|" 65) where "xs |\<inter>| ys \<equiv> inf xs ys"
abbreviation fminus :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|-|" 65) where "xs |-| ys \<equiv> minus xs ys"

instantiation fset :: (equal) equal
begin
definition "HOL.equal A B \<longleftrightarrow> A |\<subseteq>| B \<and> B |\<subseteq>| A"
instance by intro_classes (auto simp add: equal_fset_def)
end

instantiation fset :: (type) conditionally_complete_lattice
begin

context includes lifting_syntax
begin

lemma right_total_Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A)
    (\<lambda>S. if finite (\<Inter>S \<inter> Collect (Domainp A)) then \<Inter>S \<inter> Collect (Domainp A) else {})
      (\<lambda>S. if finite (Inf S) then Inf S else {})"
    by transfer_prover

lemma Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Inf A) then Inf A else {})
    (\<lambda>A. if finite (Inf A) then Inf A else {})"
  by transfer_prover

lift_definition Inf_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Inf A) then Inf A else {}"
parametric right_total_Inf_fset_transfer Inf_fset_transfer by simp

lemma Sup_fset_transfer:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Sup A) then Sup A else {})
  (\<lambda>A. if finite (Sup A) then Sup A else {})" by transfer_prover

lift_definition Sup_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Sup A) then Sup A else {}"
parametric Sup_fset_transfer by simp

lemma finite_Sup: "\<exists>z. finite z \<and> (\<forall>a. a \<in> X \<longrightarrow> a \<le> z) \<Longrightarrow> finite (Sup X)"
by (auto intro: finite_subset)

lemma transfer_bdd_below[transfer_rule]: "(rel_set (pcr_fset op =) ===> op =) bdd_below bdd_below"
  by auto

end

instance
proof
  fix x z :: "'a fset"
  fix X :: "'a fset set"
  {
    assume "x \<in> X" "bdd_below X"
    then show "Inf X |\<subseteq>| x" by transfer auto
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> z |\<subseteq>| x)"
    then show "z |\<subseteq>| Inf X" by transfer (clarsimp, blast)
  next
    assume "x \<in> X" "bdd_above X"
    then obtain z where "x \<in> X" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
      by (auto simp: bdd_above_def)
    then show "x |\<subseteq>| Sup X"
      by transfer (auto intro!: finite_Sup)
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
    then show "Sup X |\<subseteq>| z" by transfer (clarsimp, blast)
  }
qed
end

instantiation fset :: (finite) complete_lattice
begin

lift_definition top_fset :: "'a fset" is UNIV parametric right_total_UNIV_transfer UNIV_transfer
  by simp

instance
  by (standard; transfer; auto)

end

instantiation fset :: (finite) complete_boolean_algebra
begin

lift_definition uminus_fset :: "'a fset \<Rightarrow> 'a fset" is uminus
  parametric right_total_Compl_transfer Compl_transfer by simp

instance
  by (standard; transfer) (simp_all add: Diff_eq)

end

abbreviation fUNIV :: "'a::finite fset" where "fUNIV \<equiv> top"
abbreviation fuminus :: "'a::finite fset \<Rightarrow> 'a fset" ("|-| _" [81] 80) where "|-| x \<equiv> uminus x"

declare top_fset.rep_eq[simp]

subsection \<open>Other operations\<close>

lift_definition finsert :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is insert parametric Lifting_Set.insert_transfer
  by simp

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST finsert x {|xs|}"
  "{|x|}"     == "CONST finsert x {||}"

lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is Set.member
  parametric member_transfer .

abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

context includes lifting_syntax
begin

lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Set.filter
  parametric Lifting_Set.filter_transfer unfolding Set.filter_def by simp

lift_definition fPow :: "'a fset \<Rightarrow> 'a fset fset" is Pow parametric Pow_transfer
by (simp add: finite_subset)

lift_definition fcard :: "'a fset \<Rightarrow> nat" is card parametric card_transfer .

lift_definition fimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" (infixr "|`|" 90) is image
  parametric image_transfer by simp

lift_definition fthe_elem :: "'a fset \<Rightarrow> 'a" is the_elem .

lift_definition fbind :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> 'b fset" is Set.bind parametric bind_transfer
by (simp add: Set.bind_def)

lift_definition ffUnion :: "'a fset fset \<Rightarrow> 'a fset" is Union parametric Union_transfer by simp

lift_definition fBall :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Ball parametric Ball_transfer .
lift_definition fBex :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Bex parametric Bex_transfer .

lift_definition ffold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'b" is Finite_Set.fold .

lift_definition fset_of_list :: "'a list \<Rightarrow> 'a fset" is set by (rule finite_set)

lift_definition ffSigma :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> ('a \<times> 'b) fset" is Product_Type.Sigma by auto (* mhahn *)

abbreviation (* mhahn *)
  fTimes :: "'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) fset"  (infixr "|\<times>|" 80) where
  "A |\<times>| B == ffSigma A (%_. B)"

abbreviation ffUnionAbb :: "'a fset fset \<Rightarrow> 'a fset"  ("\<Union>|" 1000) (* mhahn *)
  where "(\<Union>| x) \<equiv> ffUnion x"

subsection \<open>Transferred lemmas from Set.thy\<close>

lemmas fset_eqI = set_eqI[Transfer.transferred]
lemmas fset_eq_iff[no_atp] = set_eq_iff[Transfer.transferred]
lemmas fBallI[intro!] = ballI[Transfer.transferred]
lemmas fbspec[dest?] = bspec[Transfer.transferred]
lemmas fBallE[elim] = ballE[Transfer.transferred]
lemmas fBexI[intro] = bexI[Transfer.transferred]
lemmas rev_fBexI[intro?] = rev_bexI[Transfer.transferred]
lemmas fBexCI = bexCI[Transfer.transferred]
lemmas fBexE[elim!] = bexE[Transfer.transferred]
lemmas fBall_triv[simp] = ball_triv[Transfer.transferred]
lemmas fBex_triv[simp] = bex_triv[Transfer.transferred]
lemmas fBex_triv_one_point1[simp] = bex_triv_one_point1[Transfer.transferred]
lemmas fBex_triv_one_point2[simp] = bex_triv_one_point2[Transfer.transferred]
lemmas fBex_one_point1[simp] = bex_one_point1[Transfer.transferred]
lemmas fBex_one_point2[simp] = bex_one_point2[Transfer.transferred]
lemmas fBall_one_point1[simp] = ball_one_point1[Transfer.transferred]
lemmas fBall_one_point2[simp] = ball_one_point2[Transfer.transferred]
lemmas fBall_conj_distrib = ball_conj_distrib[Transfer.transferred]
lemmas fBex_disj_distrib = bex_disj_distrib[Transfer.transferred]
lemmas fBall_cong = ball_cong[Transfer.transferred]
lemmas fBex_cong = bex_cong[Transfer.transferred]
lemmas fsubsetI[intro!] = subsetI[Transfer.transferred]
lemmas fsubsetD[elim, intro?] = subsetD[Transfer.transferred]
lemmas rev_fsubsetD[no_atp,intro?] = rev_subsetD[Transfer.transferred]
lemmas fsubsetCE[no_atp,elim] = subsetCE[Transfer.transferred]
lemmas fsubset_eq[no_atp] = subset_eq[Transfer.transferred]
lemmas contra_fsubsetD[no_atp] = contra_subsetD[Transfer.transferred]
lemmas fsubset_refl = subset_refl[Transfer.transferred]
lemmas fsubset_trans = subset_trans[Transfer.transferred]
lemmas fset_rev_mp = set_rev_mp[Transfer.transferred]
lemmas fset_mp = set_mp[Transfer.transferred]
lemmas fsubset_not_fsubset_eq[code] = subset_not_subset_eq[Transfer.transferred]
lemmas eq_fmem_trans = eq_mem_trans[Transfer.transferred]
lemmas fsubset_antisym[intro!] = subset_antisym[Transfer.transferred]
lemmas fequalityD1 = equalityD1[Transfer.transferred]
lemmas fequalityD2 = equalityD2[Transfer.transferred]
lemmas fequalityE = equalityE[Transfer.transferred]
lemmas fequalityCE[elim] = equalityCE[Transfer.transferred]
lemmas eqfset_imp_iff = eqset_imp_iff[Transfer.transferred]
lemmas eqfelem_imp_iff = eqelem_imp_iff[Transfer.transferred]
lemmas fempty_iff[simp] = empty_iff[Transfer.transferred]
lemmas fempty_fsubsetI[iff] = empty_subsetI[Transfer.transferred]
lemmas equalsffemptyI = equals0I[Transfer.transferred]
lemmas equalsffemptyD = equals0D[Transfer.transferred]
lemmas fBall_fempty[simp] = ball_empty[Transfer.transferred]
lemmas fBex_fempty[simp] = bex_empty[Transfer.transferred]
lemmas fPow_iff[iff] = Pow_iff[Transfer.transferred]
lemmas fPowI = PowI[Transfer.transferred]
lemmas fPowD = PowD[Transfer.transferred]
lemmas fPow_bottom = Pow_bottom[Transfer.transferred]
lemmas fPow_top = Pow_top[Transfer.transferred]
lemmas fPow_not_fempty = Pow_not_empty[Transfer.transferred]
lemmas finter_iff[simp] = Int_iff[Transfer.transferred]
lemmas finterI[intro!] = IntI[Transfer.transferred]
lemmas finterD1 = IntD1[Transfer.transferred]
lemmas finterD2 = IntD2[Transfer.transferred]
lemmas finterE[elim!] = IntE[Transfer.transferred]
lemmas funion_iff[simp] = Un_iff[Transfer.transferred]
lemmas funionI1[elim?] = UnI1[Transfer.transferred]
lemmas funionI2[elim?] = UnI2[Transfer.transferred]
lemmas funionCI[intro!] = UnCI[Transfer.transferred]
lemmas funionE[elim!] = UnE[Transfer.transferred]
lemmas fminus_iff[simp] = Diff_iff[Transfer.transferred]
lemmas fminusI[intro!] = DiffI[Transfer.transferred]
lemmas fminusD1 = DiffD1[Transfer.transferred]
lemmas fminusD2 = DiffD2[Transfer.transferred]
lemmas fminusE[elim!] = DiffE[Transfer.transferred]
lemmas finsert_iff[simp] = insert_iff[Transfer.transferred]
lemmas finsertI1 = insertI1[Transfer.transferred]
lemmas finsertI2 = insertI2[Transfer.transferred]
lemmas finsertE[elim!] = insertE[Transfer.transferred]
lemmas finsertCI[intro!] = insertCI[Transfer.transferred]
lemmas fsubset_finsert_iff = subset_insert_iff[Transfer.transferred]
lemmas finsert_ident = insert_ident[Transfer.transferred]
lemmas fsingletonI[intro!,no_atp] = singletonI[Transfer.transferred]
lemmas fsingletonD[dest!,no_atp] = singletonD[Transfer.transferred]
lemmas fsingleton_iff = singleton_iff[Transfer.transferred]
lemmas fsingleton_inject[dest!] = singleton_inject[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq[iff,no_atp] = singleton_insert_inj_eq[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq'[iff,no_atp] = singleton_insert_inj_eq'[Transfer.transferred]
lemmas fsubset_fsingletonD = subset_singletonD[Transfer.transferred]
lemmas fminus_single_finsert = Diff_single_insert[Transfer.transferred]
lemmas fdoubleton_eq_iff = doubleton_eq_iff[Transfer.transferred]
lemmas funion_fsingleton_iff = Un_singleton_iff[Transfer.transferred]
lemmas fsingleton_funion_iff = singleton_Un_iff[Transfer.transferred]
lemmas fimage_eqI[simp, intro] = image_eqI[Transfer.transferred]
lemmas fimageI = imageI[Transfer.transferred]
lemmas rev_fimage_eqI = rev_image_eqI[Transfer.transferred]
lemmas fimageE[elim!] = imageE[Transfer.transferred]
lemmas Compr_fimage_eq = Compr_image_eq[Transfer.transferred]
lemmas fimage_funion = image_Un[Transfer.transferred]
lemmas fimage_iff = image_iff[Transfer.transferred]
lemmas fimage_fsubset_iff[no_atp] = image_subset_iff[Transfer.transferred]
lemmas fimage_fsubsetI = image_subsetI[Transfer.transferred]
lemmas fimage_ident[simp] = image_ident[Transfer.transferred]
lemmas if_split_fmem1 = if_split_mem1[Transfer.transferred]
lemmas if_split_fmem2 = if_split_mem2[Transfer.transferred]
lemmas pfsubsetI[intro!,no_atp] = psubsetI[Transfer.transferred]
lemmas pfsubsetE[elim!,no_atp] = psubsetE[Transfer.transferred]
lemmas pfsubset_finsert_iff = psubset_insert_iff[Transfer.transferred]
lemmas pfsubset_eq = psubset_eq[Transfer.transferred]
lemmas pfsubset_imp_fsubset = psubset_imp_subset[Transfer.transferred]
lemmas pfsubset_trans = psubset_trans[Transfer.transferred]
lemmas pfsubsetD = psubsetD[Transfer.transferred]
lemmas pfsubset_fsubset_trans = psubset_subset_trans[Transfer.transferred]
lemmas fsubset_pfsubset_trans = subset_psubset_trans[Transfer.transferred]
lemmas pfsubset_imp_ex_fmem = psubset_imp_ex_mem[Transfer.transferred]
lemmas fimage_fPow_mono = image_Pow_mono[Transfer.transferred]
lemmas fimage_fPow_surj = image_Pow_surj[Transfer.transferred]
lemmas fsubset_finsertI = subset_insertI[Transfer.transferred]
lemmas fsubset_finsertI2 = subset_insertI2[Transfer.transferred]
lemmas fsubset_finsert = subset_insert[Transfer.transferred]
lemmas funion_upper1 = Un_upper1[Transfer.transferred]
lemmas funion_upper2 = Un_upper2[Transfer.transferred]
lemmas funion_least = Un_least[Transfer.transferred]
lemmas finter_lower1 = Int_lower1[Transfer.transferred]
lemmas finter_lower2 = Int_lower2[Transfer.transferred]
lemmas finter_greatest = Int_greatest[Transfer.transferred]
lemmas fminus_fsubset = Diff_subset[Transfer.transferred]
lemmas fminus_fsubset_conv = Diff_subset_conv[Transfer.transferred]
lemmas fsubset_fempty[simp] = subset_empty[Transfer.transferred]
lemmas not_pfsubset_fempty[iff] = not_psubset_empty[Transfer.transferred]
lemmas finsert_is_funion = insert_is_Un[Transfer.transferred]
lemmas finsert_not_fempty[simp] = insert_not_empty[Transfer.transferred]
lemmas fempty_not_finsert = empty_not_insert[Transfer.transferred]
lemmas finsert_absorb = insert_absorb[Transfer.transferred]
lemmas finsert_absorb2[simp] = insert_absorb2[Transfer.transferred]
lemmas finsert_commute = insert_commute[Transfer.transferred]
lemmas finsert_fsubset[simp] = insert_subset[Transfer.transferred]
lemmas finsert_inter_finsert[simp] = insert_inter_insert[Transfer.transferred]
lemmas finsert_disjoint[simp,no_atp] = insert_disjoint[Transfer.transferred]
lemmas disjoint_finsert[simp,no_atp] = disjoint_insert[Transfer.transferred]
lemmas fimage_fempty[simp] = image_empty[Transfer.transferred]
lemmas fimage_finsert[simp] = image_insert[Transfer.transferred]
lemmas fimage_constant = image_constant[Transfer.transferred]
lemmas fimage_constant_conv = image_constant_conv[Transfer.transferred]
lemmas fimage_fimage = image_image[Transfer.transferred]
lemmas finsert_fimage[simp] = insert_image[Transfer.transferred]
lemmas fimage_is_fempty[iff] = image_is_empty[Transfer.transferred]
lemmas fempty_is_fimage[iff] = empty_is_image[Transfer.transferred]
lemmas fimage_cong = image_cong[Transfer.transferred]
lemmas fimage_finter_fsubset = image_Int_subset[Transfer.transferred]
lemmas fimage_fminus_fsubset = image_diff_subset[Transfer.transferred]
lemmas finter_absorb = Int_absorb[Transfer.transferred]
lemmas finter_left_absorb = Int_left_absorb[Transfer.transferred]
lemmas finter_commute = Int_commute[Transfer.transferred]
lemmas finter_left_commute = Int_left_commute[Transfer.transferred]
lemmas finter_assoc = Int_assoc[Transfer.transferred]
lemmas finter_ac = Int_ac[Transfer.transferred]
lemmas finter_absorb1 = Int_absorb1[Transfer.transferred]
lemmas finter_absorb2 = Int_absorb2[Transfer.transferred]
lemmas finter_fempty_left = Int_empty_left[Transfer.transferred]
lemmas finter_fempty_right = Int_empty_right[Transfer.transferred]
lemmas disjoint_iff_fnot_equal = disjoint_iff_not_equal[Transfer.transferred]
lemmas finter_funion_distrib = Int_Un_distrib[Transfer.transferred]
lemmas finter_funion_distrib2 = Int_Un_distrib2[Transfer.transferred]
lemmas finter_fsubset_iff[no_atp, simp] = Int_subset_iff[Transfer.transferred]
lemmas funion_absorb = Un_absorb[Transfer.transferred]
lemmas funion_left_absorb = Un_left_absorb[Transfer.transferred]
lemmas funion_commute = Un_commute[Transfer.transferred]
lemmas funion_left_commute = Un_left_commute[Transfer.transferred]
lemmas funion_assoc = Un_assoc[Transfer.transferred]
lemmas funion_ac = Un_ac[Transfer.transferred]
lemmas funion_absorb1 = Un_absorb1[Transfer.transferred]
lemmas funion_absorb2 = Un_absorb2[Transfer.transferred]
lemmas funion_fempty_left = Un_empty_left[Transfer.transferred]
lemmas funion_fempty_right = Un_empty_right[Transfer.transferred]
lemmas funion_finsert_left[simp] = Un_insert_left[Transfer.transferred]
lemmas funion_finsert_right[simp] = Un_insert_right[Transfer.transferred]
lemmas finter_finsert_left = Int_insert_left[Transfer.transferred]
lemmas finter_finsert_left_ifffempty[simp] = Int_insert_left_if0[Transfer.transferred]
lemmas finter_finsert_left_if1[simp] = Int_insert_left_if1[Transfer.transferred]
lemmas finter_finsert_right = Int_insert_right[Transfer.transferred]
lemmas finter_finsert_right_ifffempty[simp] = Int_insert_right_if0[Transfer.transferred]
lemmas finter_finsert_right_if1[simp] = Int_insert_right_if1[Transfer.transferred]
lemmas funion_finter_distrib = Un_Int_distrib[Transfer.transferred]
lemmas funion_finter_distrib2 = Un_Int_distrib2[Transfer.transferred]
lemmas funion_finter_crazy = Un_Int_crazy[Transfer.transferred]
lemmas fsubset_funion_eq = subset_Un_eq[Transfer.transferred]
lemmas funion_fempty[iff] = Un_empty[Transfer.transferred]
lemmas funion_fsubset_iff[no_atp, simp] = Un_subset_iff[Transfer.transferred]
lemmas funion_fminus_finter = Un_Diff_Int[Transfer.transferred]
lemmas fminus_finter2 = Diff_Int2[Transfer.transferred]
lemmas funion_finter_assoc_eq = Un_Int_assoc_eq[Transfer.transferred]
lemmas fBall_funion = ball_Un[Transfer.transferred]
lemmas fBex_funion = bex_Un[Transfer.transferred]
lemmas fminus_eq_fempty_iff[simp,no_atp] = Diff_eq_empty_iff[Transfer.transferred]
lemmas fminus_cancel[simp] = Diff_cancel[Transfer.transferred]
lemmas fminus_idemp[simp] = Diff_idemp[Transfer.transferred]
lemmas fminus_triv = Diff_triv[Transfer.transferred]
lemmas fempty_fminus[simp] = empty_Diff[Transfer.transferred]
lemmas fminus_fempty[simp] = Diff_empty[Transfer.transferred]
lemmas fminus_finsertffempty[simp,no_atp] = Diff_insert0[Transfer.transferred]
lemmas fminus_finsert = Diff_insert[Transfer.transferred]
lemmas fminus_finsert2 = Diff_insert2[Transfer.transferred]
lemmas finsert_fminus_if = insert_Diff_if[Transfer.transferred]
lemmas finsert_fminus1[simp] = insert_Diff1[Transfer.transferred]
lemmas finsert_fminus_single[simp] = insert_Diff_single[Transfer.transferred]
lemmas finsert_fminus = insert_Diff[Transfer.transferred]
lemmas fminus_finsert_absorb = Diff_insert_absorb[Transfer.transferred]
lemmas fminus_disjoint[simp] = Diff_disjoint[Transfer.transferred]
lemmas fminus_partition = Diff_partition[Transfer.transferred]
lemmas double_fminus = double_diff[Transfer.transferred]
lemmas funion_fminus_cancel[simp] = Un_Diff_cancel[Transfer.transferred]
lemmas funion_fminus_cancel2[simp] = Un_Diff_cancel2[Transfer.transferred]
lemmas fminus_funion = Diff_Un[Transfer.transferred]
lemmas fminus_finter = Diff_Int[Transfer.transferred]
lemmas funion_fminus = Un_Diff[Transfer.transferred]
lemmas finter_fminus = Int_Diff[Transfer.transferred]
lemmas fminus_finter_distrib = Diff_Int_distrib[Transfer.transferred]
lemmas fminus_finter_distrib2 = Diff_Int_distrib2[Transfer.transferred]
lemmas fUNIV_bool[no_atp] = UNIV_bool[Transfer.transferred]
lemmas fPow_fempty[simp] = Pow_empty[Transfer.transferred]
lemmas fPow_finsert = Pow_insert[Transfer.transferred]
lemmas funion_fPow_fsubset = Un_Pow_subset[Transfer.transferred]
lemmas fPow_finter_eq[simp] = Pow_Int_eq[Transfer.transferred]
lemmas fset_eq_fsubset = set_eq_subset[Transfer.transferred]
lemmas fsubset_iff[no_atp] = subset_iff[Transfer.transferred]
lemmas fsubset_iff_pfsubset_eq = subset_iff_psubset_eq[Transfer.transferred]
lemmas all_not_fin_conv[simp] = all_not_in_conv[Transfer.transferred]
lemmas ex_fin_conv = ex_in_conv[Transfer.transferred]
lemmas fimage_mono = image_mono[Transfer.transferred]
lemmas fPow_mono = Pow_mono[Transfer.transferred]
lemmas finsert_mono = insert_mono[Transfer.transferred]
lemmas funion_mono = Un_mono[Transfer.transferred]
lemmas finter_mono = Int_mono[Transfer.transferred]
lemmas fminus_mono = Diff_mono[Transfer.transferred]
lemmas fin_mono = in_mono[Transfer.transferred]
lemmas fthe_felem_eq[simp] = the_elem_eq[Transfer.transferred]
lemmas fLeast_mono = Least_mono[Transfer.transferred]
lemmas fbind_fbind = bind_bind[Transfer.transferred]
lemmas fempty_fbind[simp] = empty_bind[Transfer.transferred]
lemmas nonfempty_fbind_const = nonempty_bind_const[Transfer.transferred]
lemmas fbind_const = bind_const[Transfer.transferred]
lemmas ffmember_filter[simp] = member_filter[Transfer.transferred]
lemmas fequalityI = equalityI[Transfer.transferred]
lemmas fset_of_list_simps[simp] = set_simps[Transfer.transferred]
lemmas fset_of_list_append[simp] = set_append[Transfer.transferred]
lemmas fset_of_list_rev[simp] = set_rev[Transfer.transferred]
lemmas fset_of_list_map[simp] = set_map[Transfer.transferred]

lemmas ffUnionMono[simp] = Complete_Lattices.Union_mono[Transfer.transferred](* mhahn *)

lemmas ffUnion_iff [simp] = Complete_Lattices.Union_iff[Transfer.transferred](* mhahn *)

lemmas ffUnionI [intro] = Complete_Lattices.UnionI[Transfer.transferred](* mhahn *)

lemmas ffUnionE [elim!] = Complete_Lattices.UnionE[Transfer.transferred](* mhahn *)

lemmas ffUnion_upper = Complete_Lattices.Union_upper[Transfer.transferred](* mhahn *)

lemmas ffUnion_least = Complete_Lattices.Union_least[Transfer.transferred](* mhahn *)

lemmas ffUnion_empty = Complete_Lattices.Union_empty[Transfer.transferred](* mhahn *)

lemmas ffUnion_UNIV = Complete_Lattices.Union_UNIV[Transfer.transferred](* mhahn *)
lemmas ffUnion_insert = Complete_Lattices.Union_insert[Transfer.transferred](* mhahn *)
lemmas ffUnion_Un_distrib [simp] = Complete_Lattices.Union_Un_distrib[Transfer.transferred](* mhahn *)
lemmas ffUnion_Int_subset = Complete_Lattices.Union_Int_subset[Transfer.transferred](* mhahn *)
lemmas ffUnion_empty_conv = Complete_Lattices.Union_empty_conv[Transfer.transferred](* mhahn *)
lemmas ffempty_Union_conv = Complete_Lattices.empty_Union_conv[Transfer.transferred](* mhahn *)
lemmas ffsubset_Pow_Union = Complete_Lattices.subset_Pow_Union[Transfer.transferred](* mhahn *)
lemmas ffUnion_Pow_eq [simp] = Complete_Lattices.Union_Pow_eq[Transfer.transferred](* mhahn *)
lemmas ffUnion_mono = Complete_Lattices.Union_mono[Transfer.transferred](* mhahn *)

  lemmas ffSigmaD1 = Product_Type.SigmaD1[Transfer.transferred](* mhahn *)
lemmas ffSigmaD2 = Product_Type.SigmaD2[Transfer.transferred](* mhahn *)
lemmas ffSigmaE2 = Product_Type.SigmaE2[Transfer.transferred](* mhahn *)
lemmas ffSigma_cong = Product_Type.Sigma_cong[Transfer.transferred](* mhahn *)
lemmas ffSigma_mono = Product_Type.Sigma_mono[Transfer.transferred](* mhahn *)
lemmas ffSigma_empty1 [simp] = Product_Type.Sigma_empty1[Transfer.transferred](* mhahn *)
lemmas ffSigma_empty2 [simp] = Product_Type.Sigma_empty2[Transfer.transferred](* mhahn *)
lemmas ffmem_Sigma_iff[iff] = Product_Type.mem_Sigma_iff[Transfer.transferred](* mhahn *)
lemmas ffSigmaI[intro!] = Product_Type.SigmaI[Transfer.transferred](* mhahn *)
lemmas ffSigmaE[elim!] = Product_Type.SigmaE[Transfer.transferred](* mhahn *)

lemma ffmem_Times_iff: "x |\<in>| A |\<times>| B \<longleftrightarrow> fst x |\<in>| A \<and> snd x |\<in>| B" by (induct x) simp (* mhahn *)

subsection \<open>Additional lemmas\<close>

subsubsection \<open>\<open>fsingleton\<close>\<close>

lemmas fsingletonE = fsingletonD [elim_format]

subsubsection \<open>\<open>femepty\<close>\<close>

lemma fempty_ffilter[simp]: "ffilter (\<lambda>_. False) A = {||}"
by transfer auto

(* FIXME, transferred doesn't work here *)
lemma femptyE [elim!]: "a |\<in>| {||} \<Longrightarrow> P"
  by simp

subsubsection \<open>\<open>fset\<close>\<close>

lemmas fset_simps[simp] = bot_fset.rep_eq finsert.rep_eq

lemma finite_fset [simp]:
  shows "finite (fset S)"
  by transfer simp

lemmas fset_cong = fset_inject

lemma filter_fset [simp]:
  shows "fset (ffilter P xs) = Collect P \<inter> fset xs"
  by transfer auto

lemma notin_fset: "x |\<notin>| S \<longleftrightarrow> x \<notin> fset S" by (simp add: fmember.rep_eq)

lemmas inter_fset[simp] = inf_fset.rep_eq

lemmas union_fset[simp] = sup_fset.rep_eq

lemmas minus_fset[simp] = minus_fset.rep_eq

subsubsection \<open>\<open>ffilter\<close>\<close>

lemma subset_ffilter:
  "ffilter P A |\<subseteq>| ffilter Q A = (\<forall> x. x |\<in>| A \<longrightarrow> P x \<longrightarrow> Q x)"
  by transfer auto

lemma eq_ffilter:
  "(ffilter P A = ffilter Q A) = (\<forall>x. x |\<in>| A \<longrightarrow> P x = Q x)"
  by transfer auto

lemma pfsubset_ffilter:
  "(\<And>x. x |\<in>| A \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> (x |\<in>| A & \<not> P x & Q x) \<Longrightarrow>
    ffilter P A |\<subset>| ffilter Q A"
  unfolding less_fset_def by (auto simp add: subset_ffilter eq_ffilter)

subsubsection \<open>\<open>fset_of_list\<close>\<close>

lemma fset_of_list_filter[simp]:
  "fset_of_list (filter P xs) = ffilter P (fset_of_list xs)"
  by transfer (auto simp: Set.filter_def)

lemma fset_of_list_subset[intro]:
  "set xs \<subseteq> set ys \<Longrightarrow> fset_of_list xs |\<subseteq>| fset_of_list ys"
  by transfer simp

lemma fset_of_list_elem: "(x |\<in>| fset_of_list xs) \<longleftrightarrow> (x \<in> set xs)"
  by transfer simp

subsubsection \<open>\<open>finsert\<close>\<close>

(* FIXME, transferred doesn't work here *)
lemma set_finsert:
  assumes "x |\<in>| A"
  obtains B where "A = finsert x B" and "x |\<notin>| B"
using assms by transfer (metis Set.set_insert finite_insert)

lemma mk_disjoint_finsert: "a |\<in>| A \<Longrightarrow> \<exists>B. A = finsert a B \<and> a |\<notin>| B"
  by (rule exI [where x = "A |-| {|a|}"]) blast

subsubsection \<open>\<open>fimage\<close>\<close>

lemma subset_fimage_iff: "(B |\<subseteq>| f|`|A) = (\<exists> AA. AA |\<subseteq>| A \<and> B = f|`|AA)"
by transfer (metis mem_Collect_eq rev_finite_subset subset_image_iff)

subsubsection \<open>bounded quantification\<close>

lemma bex_simps [simp, no_atp]:
  "\<And>A P Q. fBex A (\<lambda>x. P x \<and> Q) = (fBex A P \<and> Q)"
  "\<And>A P Q. fBex A (\<lambda>x. P \<and> Q x) = (P \<and> fBex A Q)"
  "\<And>P. fBex {||} P = False"
  "\<And>a B P. fBex (finsert a B) P = (P a \<or> fBex B P)"
  "\<And>A P f. fBex (f |`| A) P = fBex A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBex A P) = fBall A (\<lambda>x. \<not> P x)"
by auto

lemma ball_simps [simp, no_atp]:
  "\<And>A P Q. fBall A (\<lambda>x. P x \<or> Q) = (fBall A P \<or> Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<or> Q x) = (P \<or> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<longrightarrow> Q x) = (P \<longrightarrow> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P x \<longrightarrow> Q) = (fBex A P \<longrightarrow> Q)"
  "\<And>P. fBall {||} P = True"
  "\<And>a B P. fBall (finsert a B) P = (P a \<and> fBall B P)"
  "\<And>A P f. fBall (f |`| A) P = fBall A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBall A P) = fBex A (\<lambda>x. \<not> P x)"
by auto

lemma atomize_fBall:
    "(\<And>x. x |\<in>| A ==> P x) == Trueprop (fBall A (\<lambda>x. P x))"
apply (simp only: atomize_all atomize_imp)
apply (rule equal_intr_rule)
  by (transfer, simp)+

lemma fBall_mono[mono]: "P \<le> Q \<Longrightarrow> fBall S P \<le> fBall S Q"
by auto

end

subsubsection \<open>\<open>fcard\<close>\<close>

(* FIXME: improve transferred to handle bounded meta quantification *)

lemma fcard_fempty:
  "fcard {||} = 0"
  by transfer (rule card_empty)

lemma fcard_finsert_disjoint:
  "x |\<notin>| A \<Longrightarrow> fcard (finsert x A) = Suc (fcard A)"
  by transfer (rule card_insert_disjoint)

lemma fcard_finsert_if:
  "fcard (finsert x A) = (if x |\<in>| A then fcard A else Suc (fcard A))"
  by transfer (rule card_insert_if)

lemma card_0_eq [simp, no_atp]:
  "fcard A = 0 \<longleftrightarrow> A = {||}"
  by transfer (rule card_0_eq)

lemma fcard_Suc_fminus1:
  "x |\<in>| A \<Longrightarrow> Suc (fcard (A |-| {|x|})) = fcard A"
  by transfer (rule card_Suc_Diff1)

lemma fcard_fminus_fsingleton:
  "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) = fcard A - 1"
  by transfer (rule card_Diff_singleton)

lemma fcard_fminus_fsingleton_if:
  "fcard (A |-| {|x|}) = (if x |\<in>| A then fcard A - 1 else fcard A)"
  by transfer (rule card_Diff_singleton_if)

lemma fcard_fminus_finsert[simp]:
  assumes "a |\<in>| A" and "a |\<notin>| B"
  shows "fcard (A |-| finsert a B) = fcard (A |-| B) - 1"
using assms by transfer (rule card_Diff_insert)

lemma fcard_finsert: "fcard (finsert x A) = Suc (fcard (A |-| {|x|}))"
by transfer (rule card_insert)

lemma fcard_finsert_le: "fcard A \<le> fcard (finsert x A)"
by transfer (rule card_insert_le)

lemma fcard_mono:
  "A |\<subseteq>| B \<Longrightarrow> fcard A \<le> fcard B"
by transfer (rule card_mono)

lemma fcard_seteq: "A |\<subseteq>| B \<Longrightarrow> fcard B \<le> fcard A \<Longrightarrow> A = B"
by transfer (rule card_seteq)

lemma pfsubset_fcard_mono: "A |\<subset>| B \<Longrightarrow> fcard A < fcard B"
by transfer (rule psubset_card_mono)

lemma fcard_funion_finter:
  "fcard A + fcard B = fcard (A |\<union>| B) + fcard (A |\<inter>| B)"
by transfer (rule card_Un_Int)

lemma fcard_funion_disjoint:
  "A |\<inter>| B = {||} \<Longrightarrow> fcard (A |\<union>| B) = fcard A + fcard B"
by transfer (rule card_Un_disjoint)

lemma fcard_funion_fsubset:
  "B |\<subseteq>| A \<Longrightarrow> fcard (A |-| B) = fcard A - fcard B"
by transfer (rule card_Diff_subset)

lemma diff_fcard_le_fcard_fminus:
  "fcard A - fcard B \<le> fcard(A |-| B)"
by transfer (rule diff_card_le_card_Diff)

lemma fcard_fminus1_less: "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) < fcard A"
by transfer (rule card_Diff1_less)

lemma fcard_fminus2_less:
  "x |\<in>| A \<Longrightarrow> y |\<in>| A \<Longrightarrow> fcard (A |-| {|x|} |-| {|y|}) < fcard A"
by transfer (rule card_Diff2_less)

lemma fcard_fminus1_le: "fcard (A |-| {|x|}) \<le> fcard A"
by transfer (rule card_Diff1_le)

lemma fcard_pfsubset: "A |\<subseteq>| B \<Longrightarrow> fcard A < fcard B \<Longrightarrow> A < B"
by transfer (rule card_psubset)

subsubsection \<open>\<open>ffold\<close>\<close>

(* FIXME: improve transferred to handle bounded meta quantification *)

context comp_fun_commute
begin
  lemmas ffold_empty[simp] = fold_empty[Transfer.transferred]

  lemma ffold_finsert [simp]:
    assumes "x |\<notin>| A"
    shows "ffold f z (finsert x A) = f x (ffold f z A)"
    using assms by (transfer fixing: f) (rule fold_insert)

  lemma ffold_fun_left_comm:
    "f x (ffold f z A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_fun_left_comm)

  lemma ffold_finsert2:
    "x |\<notin>| A \<Longrightarrow> ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert2)

  lemma ffold_rec:
    assumes "x |\<in>| A"
    shows "ffold f z A = f x (ffold f z (A |-| {|x|}))"
    using assms by (transfer fixing: f) (rule fold_rec)

  lemma ffold_finsert_fremove:
    "ffold f z (finsert x A) = f x (ffold f z (A |-| {|x|}))"
     by (transfer fixing: f) (rule fold_insert_remove)
end

lemma ffold_fimage:
  assumes "inj_on g (fset A)"
  shows "ffold f z (g |`| A) = ffold (f \<circ> g) z A"
using assms by transfer' (rule fold_image)

lemma ffold_cong:
  assumes "comp_fun_commute f" "comp_fun_commute g"
  "\<And>x. x |\<in>| A \<Longrightarrow> f x = g x"
    and "s = t" and "A = B"
  shows "ffold f s A = ffold g t B"
using assms by transfer (metis Finite_Set.fold_cong)

context comp_fun_idem
begin

  lemma ffold_finsert_idem:
    "ffold f z (finsert x A) = f x (ffold f z A)"
    by (transfer fixing: f) (rule fold_insert_idem)

  declare ffold_finsert [simp del] ffold_finsert_idem [simp]

  lemma ffold_finsert_idem2:
    "ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert_idem2)

end

subsection \<open>Choice in fsets\<close>

lemma fset_choice:
  assumes "\<forall>x. x |\<in>| A \<longrightarrow> (\<exists>y. P x y)"
  shows "\<exists>f. \<forall>x. x |\<in>| A \<longrightarrow> P x (f x)"
  using assms by transfer metis

subsection \<open>Induction and Cases rules for fsets\<close>

lemma fset_exhaust [case_names empty insert, cases type: fset]:
  assumes fempty_case: "S = {||} \<Longrightarrow> P"
  and     finsert_case: "\<And>x S'. S = finsert x S' \<Longrightarrow> P"
  shows "P"
  using assms by transfer blast

lemma fset_induct [case_names empty insert]:
  assumes fempty_case: "P {||}"
  and     finsert_case: "\<And>x S. P S \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_induct_stronger [case_names empty insert, induct type: fset]:
  assumes empty_fset_case: "P {||}"
  and     insert_fset_case: "\<And>x S. \<lbrakk>x |\<notin>| S; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_card_induct:
  assumes empty_fset_case: "P {||}"
  and     card_fset_Suc_case: "\<And>S T. Suc (fcard S) = (fcard T) \<Longrightarrow> P S \<Longrightarrow> P T"
  shows "P S"
proof (induct S)
  case empty
  show "P {||}" by (rule empty_fset_case)
next
  case (insert x S)
  have h: "P S" by fact
  have "x |\<notin>| S" by fact
  then have "Suc (fcard S) = fcard (finsert x S)"
    by transfer auto
  then show "P (finsert x S)"
    using h card_fset_Suc_case by simp
qed

lemma fset_strong_cases:
  obtains "xs = {||}"
    | ys x where "x |\<notin>| ys" and "xs = finsert x ys"
by transfer blast

lemma fset_induct2:
  "P {||} {||} \<Longrightarrow>
  (\<And>x xs. x |\<notin>| xs \<Longrightarrow> P (finsert x xs) {||}) \<Longrightarrow>
  (\<And>y ys. y |\<notin>| ys \<Longrightarrow> P {||} (finsert y ys)) \<Longrightarrow>
  (\<And>x xs y ys. \<lbrakk>P xs ys; x |\<notin>| xs; y |\<notin>| ys\<rbrakk> \<Longrightarrow> P (finsert x xs) (finsert y ys)) \<Longrightarrow>
  P xsa ysa"
  apply (induct xsa arbitrary: ysa)
  apply (induct_tac x rule: fset_induct_stronger)
  apply simp_all
  apply (induct_tac xa rule: fset_induct_stronger)
  apply simp_all
  done

subsection \<open>Setup for Lifting/Transfer\<close>

subsubsection \<open>Relator and predicator properties\<close>

lift_definition rel_fset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" is rel_set
parametric rel_set_transfer .

lemma rel_fset_alt_def: "rel_fset R = (\<lambda>A B. (\<forall>x.\<exists>y. x|\<in>|A \<longrightarrow> y|\<in>|B \<and> R x y)
  \<and> (\<forall>y. \<exists>x. y|\<in>|B \<longrightarrow> x|\<in>|A \<and> R x y))"
apply (rule ext)+
apply transfer'
apply (subst rel_set_def[unfolded fun_eq_iff])
by blast

lemma finite_rel_set:
  assumes fin: "finite X" "finite Z"
  assumes R_S: "rel_set (R OO S) X Z"
  shows "\<exists>Y. finite Y \<and> rel_set R X Y \<and> rel_set S Y Z"
proof -
  obtain f where f: "\<forall>x\<in>X. R x (f x) \<and> (\<exists>z\<in>Z. S (f x) z)"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  obtain g where g: "\<forall>z\<in>Z. S (g z) z \<and> (\<exists>x\<in>X. R x (g z))"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  let ?Y = "f ` X \<union> g ` Z"
  have "finite ?Y" by (simp add: fin)
  moreover have "rel_set R X ?Y"
    unfolding rel_set_def
    using f g by clarsimp blast
  moreover have "rel_set S ?Y Z"
    unfolding rel_set_def
    using f g by clarsimp blast
  ultimately show ?thesis by metis
qed

subsubsection \<open>Transfer rules for the Transfer package\<close>

text \<open>Unconditional transfer rules\<close>

context includes lifting_syntax
begin

lemmas fempty_transfer [transfer_rule] = empty_transfer[Transfer.transferred]

lemma finsert_transfer [transfer_rule]:
  "(A ===> rel_fset A ===> rel_fset A) finsert finsert"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma funion_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset A ===> rel_fset A) funion funion"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma ffUnion_transfer [transfer_rule]:
  "(rel_fset (rel_fset A) ===> rel_fset A) ffUnion ffUnion"
  unfolding rel_fun_def rel_fset_alt_def by transfer (simp, fast)

lemma fimage_transfer [transfer_rule]:
  "((A ===> B) ===> rel_fset A ===> rel_fset B) fimage fimage"
  unfolding rel_fun_def rel_fset_alt_def by simp blast

lemma fBall_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> op =) ===> op =) fBall fBall"
  unfolding rel_fset_alt_def rel_fun_def by blast

lemma fBex_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> op =) ===> op =) fBex fBex"
  unfolding rel_fset_alt_def rel_fun_def by blast

(* FIXME transfer doesn't work here *)
lemma fPow_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset (rel_fset A)) fPow fPow"
  unfolding rel_fun_def
  using Pow_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred]
  by blast

lemma rel_fset_transfer [transfer_rule]:
  "((A ===> B ===> op =) ===> rel_fset A ===> rel_fset B ===> op =)
    rel_fset rel_fset"
  unfolding rel_fun_def
  using rel_set_transfer[unfolded rel_fun_def,rule_format, Transfer.transferred, where A = A and B = B]
  by simp

lemma bind_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> rel_fset B) ===> rel_fset B) fbind fbind"
  unfolding rel_fun_def
  using bind_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

text \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>

lemma fmember_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_fset A ===> op =) (op |\<in>|) (op |\<in>|)"
  using assms unfolding rel_fun_def rel_fset_alt_def bi_unique_def by metis

lemma finter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) finter finter"
  using assms unfolding rel_fun_def
  using inter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fminus_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) (op |-|) (op |-|)"
  using assms unfolding rel_fun_def
  using Diff_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fsubset_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> op =) (op |\<subseteq>|) (op |\<subseteq>|)"
  using assms unfolding rel_fun_def
  using subset_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fSup_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set (rel_fset A) ===> rel_fset A) Sup Sup"
  unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Sup_fset_transfer[unfolded rel_fun_def] by blast

(* FIXME: add right_total_fInf_transfer *)

lemma fInf_transfer [transfer_rule]:
  assumes "bi_unique A" and "bi_total A"
  shows "(rel_set (rel_fset A) ===> rel_fset A) Inf Inf"
  using assms unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Inf_fset_transfer[unfolded rel_fun_def] by blast

lemma ffilter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "((A ===> op=) ===> rel_fset A ===> rel_fset A) ffilter ffilter"
  using assms unfolding rel_fun_def
  using Lifting_Set.filter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_fset A ===> op =) fcard fcard"
  unfolding rel_fun_def
  using card_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

end

lifting_update fset.lifting
lifting_forget fset.lifting

subsection \<open>BNF setup\<close>

context
includes fset.lifting
begin

lemma rel_fset_alt:
  "rel_fset R a b \<longleftrightarrow> (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
by transfer (simp add: rel_set_def)

lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
apply (rule f_the_inv_into_f[unfolded inj_on_def])
apply (simp add: fset_inject)
apply (rule range_eqI Abs_fset_inverse[symmetric] CollectI)+
.

lemma rel_fset_aux:
"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
 ((BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage fst))\<inverse>\<inverse> OO
  BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage snd)) a b" (is "?L = ?R")
proof
  assume ?L
  define R' where "R' =
    the_inv fset (Collect (case_prod R) \<inter> (fset a \<times> fset b))" (is "_ = the_inv fset ?L'")
  have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) (transfer, simp)+
  hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
  show ?R unfolding Grp_def relcompp.simps conversep.simps
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * show "a = fimage fst R'" using conjunct1[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
    from * show "b = fimage snd R'" using conjunct2[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
  qed (auto simp add: *)
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
  apply (simp add: subset_eq Ball_def)
  apply (rule conjI)
  apply (transfer, clarsimp, metis snd_conv)
  by (transfer, clarsimp, metis fst_conv)
qed

bnf "'a fset"
  map: fimage
  sets: fset
  bd: natLeq
  wits: "{||}"
  rel: rel_fset
apply -
          apply transfer' apply simp
         apply transfer' apply force
        apply transfer apply force
       apply transfer' apply force
      apply (rule natLeq_card_order)
     apply (rule natLeq_cinfinite)
    apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
   apply (fastforce simp: rel_fset_alt)
 apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt
   rel_fset_aux[unfolded OO_Grp_alt])
apply transfer apply simp
done

lemma rel_fset_fset: "rel_set \<chi> (fset A1) (fset A2) = rel_fset \<chi> A1 A2"
  by transfer (rule refl)

end

lemmas [simp] = fset.map_comp fset.map_id fset.set_map

subsection \<open>Size setup\<close>

context includes fset.lifting begin
lift_definition size_fset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> nat" is "\<lambda>f. sum (Suc \<circ> f)" .
end

instantiation fset :: (type) size begin
definition size_fset where
  size_fset_overloaded_def: "size_fset = FSet.size_fset (\<lambda>_. 0)"
instance ..
end

lemmas size_fset_simps[simp] =
  size_fset_def[THEN meta_eq_to_obj_eq, THEN fun_cong, THEN fun_cong,
    unfolded map_fun_def comp_def id_apply]

lemmas size_fset_overloaded_simps[simp] =
  size_fset_simps[of "\<lambda>_. 0", unfolded add_0_left add_0_right,
    folded size_fset_overloaded_def]

lemma fset_size_o_map: "inj f \<Longrightarrow> size_fset g \<circ> fimage f = size_fset (g \<circ> f)"
  apply (subst fun_eq_iff)
  including fset.lifting by transfer (auto intro: sum.reindex_cong subset_inj_on)

setup \<open>
BNF_LFP_Size.register_size_global @{type_name fset} @{const_name size_fset}
  @{thm size_fset_overloaded_def} @{thms size_fset_simps size_fset_overloaded_simps}
  @{thms fset_size_o_map}
\<close>

lifting_update fset.lifting
lifting_forget fset.lifting

subsection \<open>Advanced relator customization\<close>

(* Set vs. sum relators: *)

lemma rel_set_rel_sum[simp]:
"rel_set (rel_sum \<chi> \<phi>) A1 A2 \<longleftrightarrow>
 rel_set \<chi> (Inl -` A1) (Inl -` A2) \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
(is "?L \<longleftrightarrow> ?Rl \<and> ?Rr")
proof safe
  assume L: "?L"
  show ?Rl unfolding rel_set_def Bex_def vimage_eq proof safe
    fix l1 assume "Inl l1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inl l1) a2"
    using L unfolding rel_set_def by auto
    then obtain l2 where "a2 = Inl l2 \<and> \<chi> l1 l2" by (cases a2, auto)
    thus "\<exists> l2. Inl l2 \<in> A2 \<and> \<chi> l1 l2" using a2 by auto
  next
    fix l2 assume "Inl l2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inl l2)"
    using L unfolding rel_set_def by auto
    then obtain l1 where "a1 = Inl l1 \<and> \<chi> l1 l2" by (cases a1, auto)
    thus "\<exists> l1. Inl l1 \<in> A1 \<and> \<chi> l1 l2" using a1 by auto
  qed
  show ?Rr unfolding rel_set_def Bex_def vimage_eq proof safe
    fix r1 assume "Inr r1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inr r1) a2"
    using L unfolding rel_set_def by auto
    then obtain r2 where "a2 = Inr r2 \<and> \<phi> r1 r2" by (cases a2, auto)
    thus "\<exists> r2. Inr r2 \<in> A2 \<and> \<phi> r1 r2" using a2 by auto
  next
    fix r2 assume "Inr r2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inr r2)"
    using L unfolding rel_set_def by auto
    then obtain r1 where "a1 = Inr r1 \<and> \<phi> r1 r2" by (cases a1, auto)
    thus "\<exists> r1. Inr r1 \<in> A1 \<and> \<phi> r1 r2" using a1 by auto
  qed
next
  assume Rl: "?Rl" and Rr: "?Rr"
  show ?L unfolding rel_set_def Bex_def vimage_eq proof safe
    fix a1 assume a1: "a1 \<in> A1"
    show "\<exists> a2. a2 \<in> A2 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a1)
      case (Inl l1) then obtain l2 where "Inl l2 \<in> A2 \<and> \<chi> l1 l2"
      using Rl a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r1) then obtain r2 where "Inr r2 \<in> A2 \<and> \<phi> r1 r2"
      using Rr a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  next
    fix a2 assume a2: "a2 \<in> A2"
    show "\<exists> a1. a1 \<in> A1 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a2)
      case (Inl l2) then obtain l1 where "Inl l1 \<in> A1 \<and> \<chi> l1 l2"
      using Rl a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r2) then obtain r1 where "Inr r1 \<in> A1 \<and> \<phi> r1 r2"
      using Rr a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  qed
qed

subsection \<open>Quickcheck setup\<close>

text \<open>Setup adapted from sets.\<close>

notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)

definition (in term_syntax) [code_unfold]:
"valterm_femptyset = Code_Evaluation.valtermify ({||} :: ('a :: typerep) fset)"

definition (in term_syntax) [code_unfold]:
"valtermify_finsert x s = Code_Evaluation.valtermify finsert {\<cdot>} (x :: ('a :: typerep * _)) {\<cdot>} s"

instantiation fset :: (exhaustive) exhaustive
begin

fun exhaustive_fset where
"exhaustive_fset f i = (if i = 0 then None else (f {||} orelse exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.exhaustive (\<lambda>x. if x |\<in>| A then None else f (finsert x A)) (i - 1)) (i - 1)))"

instance ..

end

instantiation fset :: (full_exhaustive) full_exhaustive
begin

fun full_exhaustive_fset where
"full_exhaustive_fset f i = (if i = 0 then None else (f valterm_femptyset orelse full_exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.full_exhaustive (\<lambda>x. if fst x |\<in>| fst A then None else f (valtermify_finsert x A)) (i - 1)) (i - 1)))"

instance ..

end

no_notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)

notation scomp (infixl "\<circ>\<rightarrow>" 60)

instantiation fset :: (random) random
begin

fun random_aux_fset :: "natural \<Rightarrow> natural \<Rightarrow> natural \<times> natural \<Rightarrow> ('a fset \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
"random_aux_fset 0 j = Quickcheck_Random.collapse (Random.select_weight [(1, Pair valterm_femptyset)])" |
"random_aux_fset (Code_Numeral.Suc i) j =
  Quickcheck_Random.collapse (Random.select_weight
    [(1, Pair valterm_femptyset),
     (Code_Numeral.Suc i,
      Quickcheck_Random.random j \<circ>\<rightarrow> (\<lambda>x. random_aux_fset i j \<circ>\<rightarrow> (\<lambda>s. Pair (valtermify_finsert x s))))])"

definition "random_fset i = random_aux_fset i i"

instance ..

end

no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Subtensors\<close>

theory Tensor_Subtensor
imports Tensor
begin

definition subtensor::"'a tensor \<Rightarrow> nat \<Rightarrow> 'a tensor" where
  "subtensor A i = tensor_from_vec (tl (dims A)) (fixed_length_sublist (vec A) (prod_list (tl (dims A))) i)"

definition subtensor_combine::"nat list \<Rightarrow> 'a tensor list \<Rightarrow> 'a tensor" where
  "subtensor_combine ds As = tensor_from_vec (length As # ds) (concat (map vec As))"

lemma length_fixed_length_sublist[simp]:
assumes "(Suc i)*l \<le> length xs"
shows "length (fixed_length_sublist xs l i) = l"
  unfolding fixed_length_sublist_def
  by (metis assms diff_add_inverse2 length_drop length_take min.absorb2 mult.commute mult_Suc take_drop)

lemma vec_subtensor[simp]:
assumes "dims A \<noteq> []" and "i < hd (dims A)"
shows "vec (subtensor A i) = fixed_length_sublist (vec A) (prod_list (tl (dims A))) i"
  by (metis (no_types, lifting) Suc_leI assms(1) assms(2) hd_Cons_tl length_fixed_length_sublist length_vec prod_list.Cons mult_le_mono1 subtensor_def vec_tensor)

lemma dims_subtensor[simp]:
assumes "dims A \<noteq> []" and "i < hd (dims A)"
shows "dims (subtensor A i) = tl (dims A)"
  using Suc_leI assms(1) assms(2) dims_tensor length_fixed_length_sublist length_vec list.collapse prod_list.Cons mult_le_mono1 subtensor_def
  by metis

lemma subtensor_combine_subtensor[simp]:
assumes "dims A \<noteq> []"
shows "subtensor_combine (tl (dims A)) (map (subtensor A) [0..<hd (dims A)]) = A"
proof -
  have length_vec_A: "hd (dims A) * prod_list (tl (dims A)) = length (Tensor.vec A)"
    by (metis assms length_vec list.collapse prod_list.Cons)
  let ?subtensor_vec = "fixed_length_sublist (vec A) (prod_list (tl (dims A)))"
  {
    fix i assume "i < hd (dims A)"
    then have "(Suc i)*(prod_list (tl (dims A))) \<le> length (vec A)"
      by (metis Suc_leI length_vec_A mult_le_mono1)
    then have "(vec \<circ> (\<lambda>i. tensor_from_vec (tl (dims A)) (?subtensor_vec i))) i = ?subtensor_vec i"
      by simp
  }
  then have 1:"map (Tensor.vec \<circ> (\<lambda>i. tensor_from_vec (tl (dims A)) (?subtensor_vec i))) [0..<hd (dims A)]
              = map ?subtensor_vec [0..<hd (dims A)]" by auto
  then have "subtensor_combine (tl (dims A)) (map (\<lambda>i. subtensor A i) [0..<hd (dims A)]) = A"
    unfolding subtensor_combine_def subtensor_def using concat_parts_eq[OF length_vec_A]
    by (auto simp add: 1 assms)
  then show ?thesis by auto
qed

lemma
assumes "\<And>A. A\<in>set As \<Longrightarrow> dims A = ds"
shows subtensor_combine_dims[simp]: "dims (subtensor_combine ds As) = length As # ds" (is ?D)
and subtensor_combine_vec[simp]: "vec (subtensor_combine ds As) = concat (map vec As)" (is ?V)
proof -
  have "\<And>v. v\<in>set (map Tensor.vec As) \<Longrightarrow> length v = prod_list ds" using assms length_vec by fastforce
  then have "length As * prod_list ds = length (concat (map Tensor.vec As))" using concat_equal_length
    by (metis length_map)
  then show ?D ?V unfolding subtensor_combine_def by simp+
qed

lemma subtensor_subtensor_combine:
assumes "\<And>A. A\<in>set As \<Longrightarrow> dims A = ds" and "i < length As"
shows "subtensor (subtensor_combine ds As) i = As ! i"
proof -
  have "fixed_length_sublist (concat (map vec As)) (prod_list ds) i = vec (As ! i)"
    using concat_parts[of "map vec As" "prod_list ds" i] assms imageE length_map length_vec
    nth_map set_map in_set_conv_nth by fastforce
  then show ?thesis
    unfolding subtensor_def using subtensor_combine_dims subtensor_combine_vec
    by (metis assms list.sel(3) nth_mem tensor_from_vec_simp)
qed

lemma subtensor_induct[case_names order_0 order_step]:
assumes order_0: "\<And>A. dims A = [] \<Longrightarrow> P A"
and order_step: "\<And>A. dims A \<noteq> [] \<Longrightarrow> (\<And>i. i < hd (dims A) \<Longrightarrow> P (subtensor A i)) \<Longrightarrow> P A"
shows "P B"
using assms proof (induction "dims B" arbitrary:B)
  case Nil
  then show ?case by auto
next
  case Cons
  then show ?case by (metis dims_subtensor list.sel(3))
qed

lemma subtensor_combine_induct[case_names order_0 order_step]:
assumes order_0:"\<And>A. dims A = [] \<Longrightarrow> P A"
and order_step:"\<And>As ds. (\<And>A. A\<in>set As \<Longrightarrow> P A) \<Longrightarrow> (\<And>A. A\<in>set As \<Longrightarrow> dims A = ds) \<Longrightarrow> P (subtensor_combine ds As)"
shows "P A"
proof (induction A rule:subtensor_induct)
  case (order_0 A)
  then show ?case by (simp add: assms(1))
next
  case (order_step A)
  have "P (subtensor_combine (tl (dims A)) (map (subtensor A) [0..<hd (dims A)]))"
    apply (rule assms(2))
      using atLeastLessThan_iff dims_subtensor imageE set_map set_upt order_step by auto
  then show ?case using subtensor_combine_subtensor[OF order_step.hyps] by metis
qed

lemma lookup_subtensor1[simp]:
assumes "i # is \<lhd> dims A"
shows "lookup (subtensor A i) is = lookup A (i # is)"
using assms
proof (induction A rule: subtensor_combine_induct)
  case order_0
  then show ?case by auto
next
  case (order_step As ds)
  have 0:"subtensor (subtensor_combine ds As) i = As ! i"
    by (metis list.discI list.sel(1) order_step.hyps order_step.prems subtensor_combine_dims subtensor_subtensor_combine valid_index_dimsE)
  have 1:"dims (subtensor_combine ds As) = length As # ds"
    using order_step subtensor_combine_def subtensor_combine_dims by force
  show ?case unfolding "0" lookup_def 1 unfolding lookup_base_Cons using  order_step.prems
    using Tensor.lookup_base_Cons dims_subtensor lookup_def list.discI list.sel(1)
    list.sel(3)  valid_index_dimsE vec_subtensor by (metis "0" "1")
qed

lemma lookup_subtensor:
assumes "is \<lhd> dims A"
shows "lookup A is = hd (vec (fold (\<lambda>i A. subtensor A i) is A))"
using assms proof (induction "is" arbitrary: A)
  case Nil
  then show ?case by (metis Tensor.lookup_base_Nil lookup_def fold_simps(1) length_0_conv valid_index_length)
next
  case (Cons a "is" A)
  then show ?case
    using dims_subtensor lookup_subtensor1 fold_simps(2) list.discI list.sel(1) list.sel(3)
    valid_indexE by (metis (no_types, lifting))
qed

lemma subtensor_eqI:
assumes "dims A \<noteq> []"
and dims_eq:"dims A = dims B"
and "\<And>i. i < hd (dims A) \<Longrightarrow> subtensor A i = subtensor B i"
shows "A=B"
proof -
  {
    fix "is" assume "is \<lhd> dims A"
    then obtain i is' where is_Cons:"is = i # is'" using assms(1) by blast
    then have "lookup A is = lookup B is"
      using lookup_subtensor1 assms by (metis \<open>is \<lhd> dims A\<close> is_Cons list.sel(1) valid_index_dimsE)
  }
  then show ?thesis using tensor_lookup_eqI[OF dims_eq] by auto
qed

end