(*  Title:      HOL/Library/Polynomial_Factorial.thy
    Author:     Brian Huffman
    Author:     Clemens Ballarin
    Author:     Amine Chaieb
    Author:     Florian Haftmann
    Author:     Manuel Eberl
*)

theory Polynomial_Factorial
imports
  Complex_Main
  "~~/src/HOL/Number_Theory/Euclidean_Algorithm"
  "~~/src/HOL/Library/Polynomial"
  "~~/src/HOL/Library/Normalized_Fraction"
begin

subsection \<open>Prelude\<close>

lemma prod_mset_mult:
  "prod_mset (image_mset (\<lambda>x. f x * g x) A) = prod_mset (image_mset f A) * prod_mset (image_mset g A)"
  by (induction A) (simp_all add: mult_ac)

lemma prod_mset_const: "prod_mset (image_mset (\<lambda>_. c) A) = c ^ size A"
  by (induction A) (simp_all add: mult_ac)

lemma dvd_field_iff: "x dvd y \<longleftrightarrow> (x = 0 \<longrightarrow> y = (0::'a::field))"
proof safe
  assume "x \<noteq> 0"
  hence "y = x * (y / x)" by (simp add: field_simps)
  thus "x dvd y" by (rule dvdI)
qed auto

lemma nat_descend_induct [case_names base descend]:
  assumes "\<And>k::nat. k > n \<Longrightarrow> P k"
  assumes "\<And>k::nat. k \<le> n \<Longrightarrow> (\<And>i. i > k \<Longrightarrow> P i) \<Longrightarrow> P k"
  shows   "P m"
  using assms by induction_schema (force intro!: wf_measure[of "\<lambda>k. Suc n - k"])+

lemma GreatestI_ex: "\<exists>k::nat. P k \<Longrightarrow> \<forall>y. P y \<longrightarrow> y < b \<Longrightarrow> P (GREATEST x. P x)"
  by (metis GreatestI)

context field
begin

subclass idom_divide ..

end

context field
begin

definition normalize_field :: "'a \<Rightarrow> 'a"
  where [simp]: "normalize_field x = (if x = 0 then 0 else 1)"
definition unit_factor_field :: "'a \<Rightarrow> 'a"
  where [simp]: "unit_factor_field x = x"
definition euclidean_size_field :: "'a \<Rightarrow> nat"
  where [simp]: "euclidean_size_field x = (if x = 0 then 0 else 1)"
definition mod_field :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where [simp]: "mod_field x y = (if y = 0 then x else 0)"

end

instantiation real :: euclidean_ring
begin

definition [simp]: "normalize_real = (normalize_field :: real \<Rightarrow> _)"
definition [simp]: "unit_factor_real = (unit_factor_field :: real \<Rightarrow> _)"
definition [simp]: "euclidean_size_real = (euclidean_size_field :: real \<Rightarrow> _)"
definition [simp]: "modulo_real = (mod_field :: real \<Rightarrow> _)"

instance by standard (simp_all add: dvd_field_iff divide_simps)
end

instantiation real :: euclidean_ring_gcd
begin

definition gcd_real :: "real \<Rightarrow> real \<Rightarrow> real" where
  "gcd_real = gcd_eucl"
definition lcm_real :: "real \<Rightarrow> real \<Rightarrow> real" where
  "lcm_real = lcm_eucl"
definition Gcd_real :: "real set \<Rightarrow> real" where
 "Gcd_real = Gcd_eucl"
definition Lcm_real :: "real set \<Rightarrow> real" where
 "Lcm_real = Lcm_eucl"

instance by standard (simp_all add: gcd_real_def lcm_real_def Gcd_real_def Lcm_real_def)

end

instantiation rat :: euclidean_ring
begin

definition [simp]: "normalize_rat = (normalize_field :: rat \<Rightarrow> _)"
definition [simp]: "unit_factor_rat = (unit_factor_field :: rat \<Rightarrow> _)"
definition [simp]: "euclidean_size_rat = (euclidean_size_field :: rat \<Rightarrow> _)"
definition [simp]: "modulo_rat = (mod_field :: rat \<Rightarrow> _)"

instance by standard (simp_all add: dvd_field_iff divide_simps)
end

instantiation rat :: euclidean_ring_gcd
begin

definition gcd_rat :: "rat \<Rightarrow> rat \<Rightarrow> rat" where
  "gcd_rat = gcd_eucl"
definition lcm_rat :: "rat \<Rightarrow> rat \<Rightarrow> rat" where
  "lcm_rat = lcm_eucl"
definition Gcd_rat :: "rat set \<Rightarrow> rat" where
 "Gcd_rat = Gcd_eucl"
definition Lcm_rat :: "rat set \<Rightarrow> rat" where
 "Lcm_rat = Lcm_eucl"

instance by standard (simp_all add: gcd_rat_def lcm_rat_def Gcd_rat_def Lcm_rat_def)

end

instantiation complex :: euclidean_ring
begin

definition [simp]: "normalize_complex = (normalize_field :: complex \<Rightarrow> _)"
definition [simp]: "unit_factor_complex = (unit_factor_field :: complex \<Rightarrow> _)"
definition [simp]: "euclidean_size_complex = (euclidean_size_field :: complex \<Rightarrow> _)"
definition [simp]: "modulo_complex = (mod_field :: complex \<Rightarrow> _)"

instance by standard (simp_all add: dvd_field_iff divide_simps)
end

instantiation complex :: euclidean_ring_gcd
begin

definition gcd_complex :: "complex \<Rightarrow> complex \<Rightarrow> complex" where
  "gcd_complex = gcd_eucl"
definition lcm_complex :: "complex \<Rightarrow> complex \<Rightarrow> complex" where
  "lcm_complex = lcm_eucl"
definition Gcd_complex :: "complex set \<Rightarrow> complex" where
 "Gcd_complex = Gcd_eucl"
definition Lcm_complex :: "complex set \<Rightarrow> complex" where
 "Lcm_complex = Lcm_eucl"

instance by standard (simp_all add: gcd_complex_def lcm_complex_def Gcd_complex_def Lcm_complex_def)

end

subsection \<open>Lifting elements into the field of fractions\<close>

definition to_fract :: "'a :: idom \<Rightarrow> 'a fract" where "to_fract x = Fract x 1"

lemma to_fract_0 [simp]: "to_fract 0 = 0"
  by (simp add: to_fract_def eq_fract Zero_fract_def)

lemma to_fract_1 [simp]: "to_fract 1 = 1"
  by (simp add: to_fract_def eq_fract One_fract_def)

lemma to_fract_add [simp]: "to_fract (x + y) = to_fract x + to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_diff [simp]: "to_fract (x - y) = to_fract x - to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_uminus [simp]: "to_fract (-x) = -to_fract x"
  by (simp add: to_fract_def)

lemma to_fract_mult [simp]: "to_fract (x * y) = to_fract x * to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_eq_iff [simp]: "to_fract x = to_fract y \<longleftrightarrow> x = y"
  by (simp add: to_fract_def eq_fract)

lemma to_fract_eq_0_iff [simp]: "to_fract x = 0 \<longleftrightarrow> x = 0"
  by (simp add: to_fract_def Zero_fract_def eq_fract)

lemma snd_quot_of_fract_nonzero [simp]: "snd (quot_of_fract x) \<noteq> 0"
  by transfer simp

lemma Fract_quot_of_fract [simp]: "Fract (fst (quot_of_fract x)) (snd (quot_of_fract x)) = x"
  by transfer (simp del: fractrel_iff, subst fractrel_normalize_quot_left, simp)

lemma to_fract_quot_of_fract:
  assumes "snd (quot_of_fract x) = 1"
  shows   "to_fract (fst (quot_of_fract x)) = x"
proof -
  have "x = Fract (fst (quot_of_fract x)) (snd (quot_of_fract x))" by simp
  also note assms
  finally show ?thesis by (simp add: to_fract_def)
qed

lemma snd_quot_of_fract_Fract_whole:
  assumes "y dvd x"
  shows   "snd (quot_of_fract (Fract x y)) = 1"
  using assms by transfer (auto simp: normalize_quot_def Let_def gcd_proj2_if_dvd)

lemma Fract_conv_to_fract: "Fract a b = to_fract a / to_fract b"
  by (simp add: to_fract_def)

lemma quot_of_fract_to_fract [simp]: "quot_of_fract (to_fract x) = (x, 1)"
  unfolding to_fract_def by transfer (simp add: normalize_quot_def)

lemma fst_quot_of_fract_eq_0_iff [simp]: "fst (quot_of_fract x) = 0 \<longleftrightarrow> x = 0"
  by transfer simp

lemma snd_quot_of_fract_to_fract [simp]: "snd (quot_of_fract (to_fract x)) = 1"
  unfolding to_fract_def by (rule snd_quot_of_fract_Fract_whole) simp_all

lemma coprime_quot_of_fract:
  "coprime (fst (quot_of_fract x)) (snd (quot_of_fract x))"
  by transfer (simp add: coprime_normalize_quot)

lemma unit_factor_snd_quot_of_fract: "unit_factor (snd (quot_of_fract x)) = 1"
  using quot_of_fract_in_normalized_fracts[of x]
  by (simp add: normalized_fracts_def case_prod_unfold)

lemma unit_factor_1_imp_normalized: "unit_factor x = 1 \<Longrightarrow> normalize x = x"
  by (subst (2) normalize_mult_unit_factor [symmetric, of x])
     (simp del: normalize_mult_unit_factor)

lemma normalize_snd_quot_of_fract: "normalize (snd (quot_of_fract x)) = snd (quot_of_fract x)"
  by (intro unit_factor_1_imp_normalized unit_factor_snd_quot_of_fract)

subsection \<open>Mapping polynomials\<close>

definition map_poly
     :: "('a :: zero \<Rightarrow> 'b :: zero) \<Rightarrow> 'a poly \<Rightarrow> 'b poly" where
  "map_poly f p = Poly (map f (coeffs p))"

lemma map_poly_0 [simp]: "map_poly f 0 = 0"
  by (simp add: map_poly_def)

lemma map_poly_1: "map_poly f 1 = [:f 1:]"
  by (simp add: map_poly_def)

lemma map_poly_1' [simp]: "f 1 = 1 \<Longrightarrow> map_poly f 1 = 1"
  by (simp add: map_poly_def one_poly_def)

lemma coeff_map_poly:
  assumes "f 0 = 0"
  shows   "coeff (map_poly f p) n = f (coeff p n)"
  by (auto simp: map_poly_def nth_default_def coeffs_def assms
        not_less Suc_le_eq coeff_eq_0 simp del: upt_Suc)

lemma coeffs_map_poly [code abstract]:
    "coeffs (map_poly f p) = strip_while (op = 0) (map f (coeffs p))"
  by (simp add: map_poly_def)

lemma set_coeffs_map_poly:
  "(\<And>x. f x = 0 \<longleftrightarrow> x = 0) \<Longrightarrow> set (coeffs (map_poly f p)) = f ` set (coeffs p)"
  by (cases "p = 0") (auto simp: coeffs_map_poly last_map last_coeffs_not_0)

lemma coeffs_map_poly':
  assumes "(\<And>x. x \<noteq> 0 \<Longrightarrow> f x \<noteq> 0)"
  shows   "coeffs (map_poly f p) = map f (coeffs p)"
  by (cases "p = 0") (auto simp: coeffs_map_poly last_map last_coeffs_not_0 assms
                           intro!: strip_while_not_last split: if_splits)

lemma degree_map_poly:
  assumes "\<And>x. x \<noteq> 0 \<Longrightarrow> f x \<noteq> 0"
  shows   "degree (map_poly f p) = degree p"
  by (simp add: degree_eq_length_coeffs coeffs_map_poly' assms)

lemma map_poly_eq_0_iff:
  assumes "f 0 = 0" "\<And>x. x \<in> set (coeffs p) \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> f x \<noteq> 0"
  shows   "map_poly f p = 0 \<longleftrightarrow> p = 0"
proof -
  {
    fix n :: nat
    have "coeff (map_poly f p) n = f (coeff p n)" by (simp add: coeff_map_poly assms)
    also have "\<dots> = 0 \<longleftrightarrow> coeff p n = 0"
    proof (cases "n < length (coeffs p)")
      case True
      hence "coeff p n \<in> set (coeffs p)" by (auto simp: coeffs_def simp del: upt_Suc)
      with assms show "f (coeff p n) = 0 \<longleftrightarrow> coeff p n = 0" by auto
    qed (auto simp: assms length_coeffs nth_default_coeffs_eq [symmetric] nth_default_def)
    finally have "(coeff (map_poly f p) n = 0) = (coeff p n = 0)" .
  }
  thus ?thesis by (auto simp: poly_eq_iff)
qed

lemma map_poly_smult:
  assumes "f 0 = 0""\<And>c x. f (c * x) = f c * f x"
  shows   "map_poly f (smult c p) = smult (f c) (map_poly f p)"
  by (intro poly_eqI) (simp_all add: assms coeff_map_poly)

lemma map_poly_pCons:
  assumes "f 0 = 0"
  shows   "map_poly f (pCons c p) = pCons (f c) (map_poly f p)"
  by (intro poly_eqI) (simp_all add: assms coeff_map_poly coeff_pCons split: nat.splits)

lemma map_poly_map_poly:
  assumes "f 0 = 0" "g 0 = 0"
  shows   "map_poly f (map_poly g p) = map_poly (f \<circ> g) p"
  by (intro poly_eqI) (simp add: coeff_map_poly assms)

lemma map_poly_id [simp]: "map_poly id p = p"
  by (simp add: map_poly_def)

lemma map_poly_id' [simp]: "map_poly (\<lambda>x. x) p = p"
  by (simp add: map_poly_def)

lemma map_poly_cong:
  assumes "(\<And>x. x \<in> set (coeffs p) \<Longrightarrow> f x = g x)"
  shows   "map_poly f p = map_poly g p"
proof -
  from assms have "map f (coeffs p) = map g (coeffs p)" by (intro map_cong) simp_all
  thus ?thesis by (simp only: coeffs_eq_iff coeffs_map_poly)
qed

lemma map_poly_monom: "f 0 = 0 \<Longrightarrow> map_poly f (monom c n) = monom (f c) n"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma map_poly_idI:
  assumes "\<And>x. x \<in> set (coeffs p) \<Longrightarrow> f x = x"
  shows   "map_poly f p = p"
  using map_poly_cong[OF assms, of _ id] by simp

lemma map_poly_idI':
  assumes "\<And>x. x \<in> set (coeffs p) \<Longrightarrow> f x = x"
  shows   "p = map_poly f p"
  using map_poly_cong[OF assms, of _ id] by simp

lemma smult_conv_map_poly: "smult c p = map_poly (\<lambda>x. c * x) p"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma div_const_poly_conv_map_poly:
  assumes "[:c:] dvd p"
  shows   "p div [:c:] = map_poly (\<lambda>x. x div c) p"
proof (cases "c = 0")
  case False
  from assms obtain q where p: "p = [:c:] * q" by (erule dvdE)
  moreover {
    have "smult c q = [:c:] * q" by simp
    also have "\<dots> div [:c:] = q" by (rule nonzero_mult_div_cancel_left) (insert False, auto)
    finally have "smult c q div [:c:] = q" .
  }
  ultimately show ?thesis by (intro poly_eqI) (auto simp: coeff_map_poly False)
qed (auto intro!: poly_eqI simp: coeff_map_poly)

subsection \<open>Various facts about polynomials\<close>

lemma prod_mset_const_poly: "prod_mset (image_mset (\<lambda>x. [:f x:]) A) = [:prod_mset (image_mset f A):]"
  by (induction A) (simp_all add: one_poly_def mult_ac)

lemma degree_mod_less': "b \<noteq> 0 \<Longrightarrow> a mod b \<noteq> 0 \<Longrightarrow> degree (a mod b) < degree b"
  using degree_mod_less[of b a] by auto

lemma is_unit_const_poly_iff:
    "[:c :: 'a :: {comm_semiring_1,semiring_no_zero_divisors}:] dvd 1 \<longleftrightarrow> c dvd 1"
  by (auto simp: one_poly_def)

lemma is_unit_poly_iff:
  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  shows "p dvd 1 \<longleftrightarrow> (\<exists>c. p = [:c:] \<and> c dvd 1)"
proof safe
  assume "p dvd 1"
  then obtain q where pq: "1 = p * q" by (erule dvdE)
  hence "degree 1 = degree (p * q)" by simp
  also from pq have "\<dots> = degree p + degree q" by (intro degree_mult_eq) auto
  finally have "degree p = 0" by simp
  from degree_eq_zeroE[OF this] obtain c where c: "p = [:c:]" .
  with \<open>p dvd 1\<close> show "\<exists>c. p = [:c:] \<and> c dvd 1"
    by (auto simp: is_unit_const_poly_iff)
qed (auto simp: is_unit_const_poly_iff)

lemma is_unit_polyE:
  fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  assumes "p dvd 1" obtains c where "p = [:c:]" "c dvd 1"
  using assms by (subst (asm) is_unit_poly_iff) blast

lemma smult_eq_iff:
  assumes "(b :: 'a :: field) \<noteq> 0"
  shows   "smult a p = smult b q \<longleftrightarrow> smult (a / b) p = q"
proof
  assume "smult a p = smult b q"
  also from assms have "smult (inverse b) \<dots> = q" by simp
  finally show "smult (a / b) p = q" by (simp add: field_simps)
qed (insert assms, auto)

lemma irreducible_const_poly_iff:
  fixes c :: "'a :: {comm_semiring_1,semiring_no_zero_divisors}"
  shows "irreducible [:c:] \<longleftrightarrow> irreducible c"
proof
  assume A: "irreducible c"
  show "irreducible [:c:]"
  proof (rule irreducibleI)
    fix a b assume ab: "[:c:] = a * b"
    hence "degree [:c:] = degree (a * b)" by (simp only: )
    also from A ab have "a \<noteq> 0" "b \<noteq> 0" by auto
    hence "degree (a * b) = degree a + degree b" by (simp add: degree_mult_eq)
    finally have "degree a = 0" "degree b = 0" by auto
    then obtain a' b' where ab': "a = [:a':]" "b = [:b':]" by (auto elim!: degree_eq_zeroE)
    from ab have "coeff [:c:] 0 = coeff (a * b) 0" by (simp only: )
    hence "c = a' * b'" by (simp add: ab' mult_ac)
    from A and this have "a' dvd 1 \<or> b' dvd 1" by (rule irreducibleD)
    with ab' show "a dvd 1 \<or> b dvd 1" by (auto simp: one_poly_def)
  qed (insert A, auto simp: irreducible_def is_unit_poly_iff)
next
  assume A: "irreducible [:c:]"
  show "irreducible c"
  proof (rule irreducibleI)
    fix a b assume ab: "c = a * b"
    hence "[:c:] = [:a:] * [:b:]" by (simp add: mult_ac)
    from A and this have "[:a:] dvd 1 \<or> [:b:] dvd 1" by (rule irreducibleD)
    thus "a dvd 1 \<or> b dvd 1" by (simp add: one_poly_def)
  qed (insert A, auto simp: irreducible_def one_poly_def)
qed

lemma lead_coeff_monom [simp]: "lead_coeff (monom c n) = c"
  by (cases "c = 0") (simp_all add: lead_coeff_def degree_monom_eq)

subsection \<open>Normalisation of polynomials\<close>

instantiation poly :: ("{normalization_semidom,idom_divide}") normalization_semidom
begin

definition unit_factor_poly :: "'a poly \<Rightarrow> 'a poly"
  where "unit_factor_poly p = monom (unit_factor (lead_coeff p)) 0"

definition normalize_poly :: "'a poly \<Rightarrow> 'a poly"
  where "normalize_poly p = map_poly (\<lambda>x. x div unit_factor (lead_coeff p)) p"

lemma normalize_poly_altdef:
  "normalize p = p div [:unit_factor (lead_coeff p):]"
proof (cases "p = 0")
  case False
  thus ?thesis
    by (subst div_const_poly_conv_map_poly)
       (auto simp: normalize_poly_def const_poly_dvd_iff lead_coeff_def )
qed (auto simp: normalize_poly_def)

instance
proof
  fix p :: "'a poly"
  show "unit_factor p * normalize p = p"
    by (cases "p = 0")
       (simp_all add: unit_factor_poly_def normalize_poly_def monom_0
          smult_conv_map_poly map_poly_map_poly o_def)
next
  fix p :: "'a poly"
  assume "is_unit p"
  then obtain c where p: "p = [:c:]" "is_unit c" by (auto simp: is_unit_poly_iff)
  thus "normalize p = 1"
    by (simp add: normalize_poly_def map_poly_pCons is_unit_normalize one_poly_def)
next
  fix p :: "'a poly" assume "p \<noteq> 0"
  thus "is_unit (unit_factor p)"
    by (simp add: unit_factor_poly_def monom_0 is_unit_poly_iff)
qed (simp_all add: normalize_poly_def unit_factor_poly_def monom_0 lead_coeff_mult unit_factor_mult)

end

lemma unit_factor_pCons:
  "unit_factor (pCons a p) = (if p = 0 then monom (unit_factor a) 0 else unit_factor p)"
  by (simp add: unit_factor_poly_def)

lemma normalize_monom [simp]:
  "normalize (monom a n) = monom (normalize a) n"
  by (simp add: map_poly_monom normalize_poly_def)

lemma unit_factor_monom [simp]:
  "unit_factor (monom a n) = monom (unit_factor a) 0"
  by (simp add: unit_factor_poly_def )

lemma normalize_const_poly: "normalize [:c:] = [:normalize c:]"
  by (simp add: normalize_poly_def map_poly_pCons)

lemma normalize_smult: "normalize (smult c p) = smult (normalize c) (normalize p)"
proof -
  have "smult c p = [:c:] * p" by simp
  also have "normalize \<dots> = smult (normalize c) (normalize p)"
    by (subst normalize_mult) (simp add: normalize_const_poly)
  finally show ?thesis .
qed

lemma is_unit_smult_iff: "smult c p dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
proof -
  have "smult c p = [:c:] * p" by simp
  also have "\<dots> dvd 1 \<longleftrightarrow> c dvd 1 \<and> p dvd 1"
  proof safe
    assume A: "[:c:] * p dvd 1"
    thus "p dvd 1" by (rule dvd_mult_right)
    from A obtain q where B: "1 = [:c:] * p * q" by (erule dvdE)
    have "c dvd c * (coeff p 0 * coeff q 0)" by simp
    also have "\<dots> = coeff ([:c:] * p * q) 0" by (simp add: mult.assoc coeff_mult)
    also note B [symmetric]
    finally show "c dvd 1" by simp
  next
    assume "c dvd 1" "p dvd 1"
    from \<open>c dvd 1\<close> obtain d where "1 = c * d" by (erule dvdE)
    hence "1 = [:c:] * [:d:]" by (simp add: one_poly_def mult_ac)
    hence "[:c:] dvd 1" by (rule dvdI)
    from mult_dvd_mono[OF this \<open>p dvd 1\<close>] show "[:c:] * p dvd 1" by simp
  qed
  finally show ?thesis .
qed

subsection \<open>Content and primitive part of a polynomial\<close>

definition content :: "('a :: semiring_Gcd poly) \<Rightarrow> 'a" where
  "content p = Gcd (set (coeffs p))"

lemma content_0 [simp]: "content 0 = 0"
  by (simp add: content_def)

lemma content_1 [simp]: "content 1 = 1"
  by (simp add: content_def)

lemma content_const [simp]: "content [:c:] = normalize c"
  by (simp add: content_def cCons_def)

lemma const_poly_dvd_iff_dvd_content:
  fixes c :: "'a :: semiring_Gcd"
  shows "[:c:] dvd p \<longleftrightarrow> c dvd content p"
proof (cases "p = 0")
  case [simp]: False
  have "[:c:] dvd p \<longleftrightarrow> (\<forall>n. c dvd coeff p n)" by (rule const_poly_dvd_iff)
  also have "\<dots> \<longleftrightarrow> (\<forall>a\<in>set (coeffs p). c dvd a)"
  proof safe
    fix n :: nat assume "\<forall>a\<in>set (coeffs p). c dvd a"
    thus "c dvd coeff p n"
      by (cases "n \<le> degree p") (auto simp: coeff_eq_0 coeffs_def split: if_splits)
  qed (auto simp: coeffs_def simp del: upt_Suc split: if_splits)
  also have "\<dots> \<longleftrightarrow> c dvd content p"
    by (simp add: content_def dvd_Gcd_iff mult.commute [of "unit_factor x" for x]
          dvd_mult_unit_iff lead_coeff_nonzero)
  finally show ?thesis .
qed simp_all

lemma content_dvd [simp]: "[:content p:] dvd p"
  by (subst const_poly_dvd_iff_dvd_content) simp_all

lemma content_dvd_coeff [simp]: "content p dvd coeff p n"
  by (cases "n \<le> degree p")
     (auto simp: content_def coeffs_def not_le coeff_eq_0 simp del: upt_Suc intro: Gcd_dvd)

lemma content_dvd_coeffs: "c \<in> set (coeffs p) \<Longrightarrow> content p dvd c"
  by (simp add: content_def Gcd_dvd)

lemma normalize_content [simp]: "normalize (content p) = content p"
  by (simp add: content_def)

lemma is_unit_content_iff [simp]: "is_unit (content p) \<longleftrightarrow> content p = 1"
proof
  assume "is_unit (content p)"
  hence "normalize (content p) = 1" by (simp add: is_unit_normalize del: normalize_content)
  thus "content p = 1" by simp
qed auto

lemma content_smult [simp]: "content (smult c p) = normalize c * content p"
  by (simp add: content_def coeffs_smult Gcd_mult)

lemma content_eq_zero_iff [simp]: "content p = 0 \<longleftrightarrow> p = 0"
  by (auto simp: content_def simp: poly_eq_iff coeffs_def)

definition primitive_part :: "'a :: {semiring_Gcd,idom_divide} poly \<Rightarrow> 'a poly" where
  "primitive_part p = (if p = 0 then 0 else map_poly (\<lambda>x. x div content p) p)"

lemma primitive_part_0 [simp]: "primitive_part 0 = 0"
  by (simp add: primitive_part_def)

lemma content_times_primitive_part [simp]:
  fixes p :: "'a :: {idom_divide, semiring_Gcd} poly"
  shows "smult (content p) (primitive_part p) = p"
proof (cases "p = 0")
  case False
  thus ?thesis
  unfolding primitive_part_def
  by (auto simp: smult_conv_map_poly map_poly_map_poly o_def content_dvd_coeffs
           intro: map_poly_idI)
qed simp_all

lemma primitive_part_eq_0_iff [simp]: "primitive_part p = 0 \<longleftrightarrow> p = 0"
proof (cases "p = 0")
  case False
  hence "primitive_part p = map_poly (\<lambda>x. x div content p) p"
    by (simp add:  primitive_part_def)
  also from False have "\<dots> = 0 \<longleftrightarrow> p = 0"
    by (intro map_poly_eq_0_iff) (auto simp: dvd_div_eq_0_iff content_dvd_coeffs)
  finally show ?thesis using False by simp
qed simp

lemma content_primitive_part [simp]:
  assumes "p \<noteq> 0"
  shows   "content (primitive_part p) = 1"
proof -
  have "p = smult (content p) (primitive_part p)" by simp
  also have "content \<dots> = content p * content (primitive_part p)"
    by (simp del: content_times_primitive_part)
  finally show ?thesis using assms by simp
qed

lemma content_decompose:
  fixes p :: "'a :: semiring_Gcd poly"
  obtains p' where "p = smult (content p) p'" "content p' = 1"
proof (cases "p = 0")
  case True
  thus ?thesis by (intro that[of 1]) simp_all
next
  case False
  from content_dvd[of p] obtain r where r: "p = [:content p:] * r" by (erule dvdE)
  have "content p * 1 = content p * content r" by (subst r) simp
  with False have "content r = 1" by (subst (asm) mult_left_cancel) simp_all
  with r show ?thesis by (intro that[of r]) simp_all
qed

lemma smult_content_normalize_primitive_part [simp]:
  "smult (content p) (normalize (primitive_part p)) = normalize p"
proof -
  have "smult (content p) (normalize (primitive_part p)) =
          normalize ([:content p:] * primitive_part p)"
    by (subst normalize_mult) (simp_all add: normalize_const_poly)
  also have "[:content p:] * primitive_part p = p" by simp
  finally show ?thesis .
qed

lemma content_dvd_contentI [intro]:
  "p dvd q \<Longrightarrow> content p dvd content q"
  using const_poly_dvd_iff_dvd_content content_dvd dvd_trans by blast

lemma primitive_part_const_poly [simp]: "primitive_part [:x:] = [:unit_factor x:]"
  by (simp add: primitive_part_def map_poly_pCons)

lemma primitive_part_prim: "content p = 1 \<Longrightarrow> primitive_part p = p"
  by (auto simp: primitive_part_def)

lemma degree_primitive_part [simp]: "degree (primitive_part p) = degree p"
proof (cases "p = 0")
  case False
  have "p = smult (content p) (primitive_part p)" by simp
  also from False have "degree \<dots> = degree (primitive_part p)"
    by (subst degree_smult_eq) simp_all
  finally show ?thesis ..
qed simp_all

subsection \<open>Lifting polynomial coefficients to the field of fractions\<close>

abbreviation (input) fract_poly
  where "fract_poly \<equiv> map_poly to_fract"

abbreviation (input) unfract_poly
  where "unfract_poly \<equiv> map_poly (fst \<circ> quot_of_fract)"

lemma fract_poly_smult [simp]: "fract_poly (smult c p) = smult (to_fract c) (fract_poly p)"
  by (simp add: smult_conv_map_poly map_poly_map_poly o_def)

lemma fract_poly_0 [simp]: "fract_poly 0 = 0"
  by (simp add: poly_eqI coeff_map_poly)

lemma fract_poly_1 [simp]: "fract_poly 1 = 1"
  by (simp add: one_poly_def map_poly_pCons)

lemma fract_poly_add [simp]:
  "fract_poly (p + q) = fract_poly p + fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma fract_poly_diff [simp]:
  "fract_poly (p - q) = fract_poly p - fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma to_fract_sum [simp]: "to_fract (sum f A) = sum (\<lambda>x. to_fract (f x)) A"
  by (cases "finite A", induction A rule: finite_induct) simp_all

lemma fract_poly_mult [simp]:
  "fract_poly (p * q) = fract_poly p * fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly coeff_mult)

lemma fract_poly_eq_iff [simp]: "fract_poly p = fract_poly q \<longleftrightarrow> p = q"
  by (auto simp: poly_eq_iff coeff_map_poly)

lemma fract_poly_eq_0_iff [simp]: "fract_poly p = 0 \<longleftrightarrow> p = 0"
  using fract_poly_eq_iff[of p 0] by (simp del: fract_poly_eq_iff)

lemma fract_poly_dvd: "p dvd q \<Longrightarrow> fract_poly p dvd fract_poly q"
  by (auto elim!: dvdE)

lemma prod_mset_fract_poly:
  "prod_mset (image_mset (\<lambda>x. fract_poly (f x)) A) = fract_poly (prod_mset (image_mset f A))"
  by (induction A) (simp_all add: mult_ac)

lemma is_unit_fract_poly_iff:
  "p dvd 1 \<longleftrightarrow> fract_poly p dvd 1 \<and> content p = 1"
proof safe
  assume A: "p dvd 1"
  with fract_poly_dvd[of p 1] show "is_unit (fract_poly p)" by simp
  from A show "content p = 1"
    by (auto simp: is_unit_poly_iff normalize_1_iff)
next
  assume A: "fract_poly p dvd 1" and B: "content p = 1"
  from A obtain c where c: "fract_poly p = [:c:]" by (auto simp: is_unit_poly_iff)
  {
    fix n :: nat assume "n > 0"
    have "to_fract (coeff p n) = coeff (fract_poly p) n" by (simp add: coeff_map_poly)
    also note c
    also from \<open>n > 0\<close> have "coeff [:c:] n = 0" by (simp add: coeff_pCons split: nat.splits)
    finally have "coeff p n = 0" by simp
  }
  hence "degree p \<le> 0" by (intro degree_le) simp_all
  with B show "p dvd 1" by (auto simp: is_unit_poly_iff normalize_1_iff elim!: degree_eq_zeroE)
qed

lemma fract_poly_is_unit: "p dvd 1 \<Longrightarrow> fract_poly p dvd 1"
  using fract_poly_dvd[of p 1] by simp

lemma fract_poly_smult_eqE:
  fixes c :: "'a :: {idom_divide,ring_gcd} fract"
  assumes "fract_poly p = smult c (fract_poly q)"
  obtains a b
    where "c = to_fract b / to_fract a" "smult a p = smult b q" "coprime a b" "normalize a = a"
proof -
  define a b where "a = fst (quot_of_fract c)" and "b = snd (quot_of_fract c)"
  have "smult (to_fract a) (fract_poly q) = smult (to_fract b) (fract_poly p)"
    by (subst smult_eq_iff) (simp_all add: a_def b_def Fract_conv_to_fract [symmetric] assms)
  hence "fract_poly (smult a q) = fract_poly (smult b p)" by (simp del: fract_poly_eq_iff)
  hence "smult b p = smult a q" by (simp only: fract_poly_eq_iff)
  moreover have "c = to_fract a / to_fract b" "coprime b a" "normalize b = b"
    by (simp_all add: a_def b_def coprime_quot_of_fract gcd.commute
          normalize_snd_quot_of_fract Fract_conv_to_fract [symmetric])
  ultimately show ?thesis by (intro that[of a b])
qed

subsection \<open>Fractional content\<close>

abbreviation (input) Lcm_coeff_denoms
    :: "'a :: {semiring_Gcd,idom_divide,ring_gcd} fract poly \<Rightarrow> 'a"
  where "Lcm_coeff_denoms p \<equiv> Lcm (snd ` quot_of_fract ` set (coeffs p))"

definition fract_content ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} fract poly \<Rightarrow> 'a fract" where
  "fract_content p =
     (let d = Lcm_coeff_denoms p in Fract (content (unfract_poly (smult (to_fract d) p))) d)"

definition primitive_part_fract ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} fract poly \<Rightarrow> 'a poly" where
  "primitive_part_fract p =
     primitive_part (unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p))"

lemma primitive_part_fract_0 [simp]: "primitive_part_fract 0 = 0"
  by (simp add: primitive_part_fract_def)

lemma fract_content_eq_0_iff [simp]:
  "fract_content p = 0 \<longleftrightarrow> p = 0"
  unfolding fract_content_def Let_def Zero_fract_def
  by (subst eq_fract) (auto simp: Lcm_0_iff map_poly_eq_0_iff)

lemma content_primitive_part_fract [simp]: "p \<noteq> 0 \<Longrightarrow> content (primitive_part_fract p) = 1"
  unfolding primitive_part_fract_def
  by (rule content_primitive_part)
     (auto simp: primitive_part_fract_def map_poly_eq_0_iff Lcm_0_iff)

lemma content_times_primitive_part_fract:
  "smult (fract_content p) (fract_poly (primitive_part_fract p)) = p"
proof -
  define p' where "p' = unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p)"
  have "fract_poly p' =
          map_poly (to_fract \<circ> fst \<circ> quot_of_fract) (smult (to_fract (Lcm_coeff_denoms p)) p)"
    unfolding primitive_part_fract_def p'_def
    by (subst map_poly_map_poly) (simp_all add: o_assoc)
  also have "\<dots> = smult (to_fract (Lcm_coeff_denoms p)) p"
  proof (intro map_poly_idI, unfold o_apply)
    fix c assume "c \<in> set (coeffs (smult (to_fract (Lcm_coeff_denoms p)) p))"
    then obtain c' where c: "c' \<in> set (coeffs p)" "c = to_fract (Lcm_coeff_denoms p) * c'"
      by (auto simp add: Lcm_0_iff coeffs_smult split: if_splits)
    note c(2)
    also have "c' = Fract (fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      by simp
    also have "to_fract (Lcm_coeff_denoms p) * \<dots> =
                 Fract (Lcm_coeff_denoms p * fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      unfolding to_fract_def by (subst mult_fract) simp_all
    also have "snd (quot_of_fract \<dots>) = 1"
      by (intro snd_quot_of_fract_Fract_whole dvd_mult2 dvd_Lcm) (insert c(1), auto)
    finally show "to_fract (fst (quot_of_fract c)) = c"
      by (rule to_fract_quot_of_fract)
  qed
  also have "p' = smult (content p') (primitive_part p')"
    by (rule content_times_primitive_part [symmetric])
  also have "primitive_part p' = primitive_part_fract p"
    by (simp add: primitive_part_fract_def p'_def)
  also have "fract_poly (smult (content p') (primitive_part_fract p)) =
               smult (to_fract (content p')) (fract_poly (primitive_part_fract p))" by simp
  finally have "smult (to_fract (content p')) (fract_poly (primitive_part_fract p)) =
                      smult (to_fract (Lcm_coeff_denoms p)) p" .
  thus ?thesis
    by (subst (asm) smult_eq_iff)
       (auto simp add: Let_def p'_def Fract_conv_to_fract field_simps Lcm_0_iff fract_content_def)
qed

lemma fract_content_fract_poly [simp]: "fract_content (fract_poly p) = to_fract (content p)"
proof -
  have "Lcm_coeff_denoms (fract_poly p) = 1"
    by (auto simp: set_coeffs_map_poly)
  hence "fract_content (fract_poly p) =
           to_fract (content (map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p))"
    by (simp add: fract_content_def to_fract_def fract_collapse map_poly_map_poly del: Lcm_1_iff)
  also have "map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p = p"
    by (intro map_poly_idI) simp_all
  finally show ?thesis .
qed

lemma content_decompose_fract:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} fract poly"
  obtains c p' where "p = smult c (map_poly to_fract p')" "content p' = 1"
proof (cases "p = 0")
  case True
  hence "p = smult 0 (map_poly to_fract 1)" "content 1 = 1" by simp_all
  thus ?thesis ..
next
  case False
  thus ?thesis
    by (rule that[OF content_times_primitive_part_fract [symmetric] content_primitive_part_fract])
qed

subsection \<open>More properties of content and primitive part\<close>

lemma lift_prime_elem_poly:
  assumes "prime_elem (c :: 'a :: semidom)"
  shows   "prime_elem [:c:]"
proof (rule prime_elemI)
  fix a b assume *: "[:c:] dvd a * b"
  from * have dvd: "c dvd coeff (a * b) n" for n
    by (subst (asm) const_poly_dvd_iff) blast
  {
    define m where "m = (GREATEST m. \<not>c dvd coeff b m)"
    assume "\<not>[:c:] dvd b"
    hence A: "\<exists>i. \<not>c dvd coeff b i" by (subst (asm) const_poly_dvd_iff) blast
    have B: "\<forall>i. \<not>c dvd coeff b i \<longrightarrow> i < Suc (degree b)"
      by (auto intro: le_degree simp: less_Suc_eq_le)
    have coeff_m: "\<not>c dvd coeff b m" unfolding m_def by (rule GreatestI_ex[OF A B])
    have "i \<le> m" if "\<not>c dvd coeff b i" for i
      unfolding m_def by (rule Greatest_le[OF that B])
    hence dvd_b: "c dvd coeff b i" if "i > m" for i using that by force

    have "c dvd coeff a i" for i
    proof (induction i rule: nat_descend_induct[of "degree a"])
      case (base i)
      thus ?case by (simp add: coeff_eq_0)
    next
      case (descend i)
      let ?A = "{..i+m} - {i}"
      have "c dvd coeff (a * b) (i + m)" by (rule dvd)
      also have "coeff (a * b) (i + m) = (\<Sum>k\<le>i + m. coeff a k * coeff b (i + m - k))"
        by (simp add: coeff_mult)
      also have "{..i+m} = insert i ?A" by auto
      also have "(\<Sum>k\<in>\<dots>. coeff a k * coeff b (i + m - k)) =
                   coeff a i * coeff b m + (\<Sum>k\<in>?A. coeff a k * coeff b (i + m - k))"
        (is "_ = _ + ?S")
        by (subst sum.insert) simp_all
      finally have eq: "c dvd coeff a i * coeff b m + ?S" .
      moreover have "c dvd ?S"
      proof (rule dvd_sum)
        fix k assume k: "k \<in> {..i+m} - {i}"
        show "c dvd coeff a k * coeff b (i + m - k)"
        proof (cases "k < i")
          case False
          with k have "c dvd coeff a k" by (intro descend.IH) simp
          thus ?thesis by simp
        next
          case True
          hence "c dvd coeff b (i + m - k)" by (intro dvd_b) simp
          thus ?thesis by simp
        qed
      qed
      ultimately have "c dvd coeff a i * coeff b m"
        by (simp add: dvd_add_left_iff)
      with assms coeff_m show "c dvd coeff a i"
        by (simp add: prime_elem_dvd_mult_iff)
    qed
    hence "[:c:] dvd a" by (subst const_poly_dvd_iff) blast
  }
  thus "[:c:] dvd a \<or> [:c:] dvd b" by blast
qed (insert assms, simp_all add: prime_elem_def one_poly_def)

lemma prime_elem_const_poly_iff:
  fixes c :: "'a :: semidom"
  shows   "prime_elem [:c:] \<longleftrightarrow> prime_elem c"
proof
  assume A: "prime_elem [:c:]"
  show "prime_elem c"
  proof (rule prime_elemI)
    fix a b assume "c dvd a * b"
    hence "[:c:] dvd [:a:] * [:b:]" by (simp add: mult_ac)
    from A and this have "[:c:] dvd [:a:] \<or> [:c:] dvd [:b:]" by (rule prime_elem_dvd_multD)
    thus "c dvd a \<or> c dvd b" by simp
  qed (insert A, auto simp: prime_elem_def is_unit_poly_iff)
qed (auto intro: lift_prime_elem_poly)

context
begin

private lemma content_1_mult:
  fixes f g :: "'a :: {semiring_Gcd,factorial_semiring} poly"
  assumes "content f = 1" "content g = 1"
  shows   "content (f * g) = 1"
proof (cases "f * g = 0")
  case False
  from assms have "f \<noteq> 0" "g \<noteq> 0" by auto

  hence "f * g \<noteq> 0" by auto
  {
    assume "\<not>is_unit (content (f * g))"
    with False have "\<exists>p. p dvd content (f * g) \<and> prime p"
      by (intro prime_divisor_exists) simp_all
    then obtain p where "p dvd content (f * g)" "prime p" by blast
    from \<open>p dvd content (f * g)\<close> have "[:p:] dvd f * g"
      by (simp add: const_poly_dvd_iff_dvd_content)
    moreover from \<open>prime p\<close> have "prime_elem [:p:]" by (simp add: lift_prime_elem_poly)
    ultimately have "[:p:] dvd f \<or> [:p:] dvd g"
      by (simp add: prime_elem_dvd_mult_iff)
    with assms have "is_unit p" by (simp add: const_poly_dvd_iff_dvd_content)
    with \<open>prime p\<close> have False by simp
  }
  hence "is_unit (content (f * g))" by blast
  hence "normalize (content (f * g)) = 1" by (simp add: is_unit_normalize del: normalize_content)
  thus ?thesis by simp
qed (insert assms, auto)

lemma content_mult:
  fixes p q :: "'a :: {factorial_semiring, semiring_Gcd} poly"
  shows "content (p * q) = content p * content q"
proof -
  from content_decompose[of p] guess p' . note p = this
  from content_decompose[of q] guess q' . note q = this
  have "content (p * q) = content p * content q * content (p' * q')"
    by (subst p, subst q) (simp add: mult_ac normalize_mult)
  also from p q have "content (p' * q') = 1" by (intro content_1_mult)
  finally show ?thesis by simp
qed

lemma primitive_part_mult:
  fixes p q :: "'a :: {factorial_semiring, semiring_Gcd, ring_gcd, idom_divide} poly"
  shows "primitive_part (p * q) = primitive_part p * primitive_part q"
proof -
  have "primitive_part (p * q) = p * q div [:content (p * q):]"
    by (simp add: primitive_part_def div_const_poly_conv_map_poly)
  also have "\<dots> = (p div [:content p:]) * (q div [:content q:])"
    by (subst div_mult_div_if_dvd) (simp_all add: content_mult mult_ac)
  also have "\<dots> = primitive_part p * primitive_part q"
    by (simp add: primitive_part_def div_const_poly_conv_map_poly)
  finally show ?thesis .
qed

lemma primitive_part_smult:
  fixes p :: "'a :: {factorial_semiring, semiring_Gcd, ring_gcd, idom_divide} poly"
  shows "primitive_part (smult a p) = smult (unit_factor a) (primitive_part p)"
proof -
  have "smult a p = [:a:] * p" by simp
  also have "primitive_part \<dots> = smult (unit_factor a) (primitive_part p)"
    by (subst primitive_part_mult) simp_all
  finally show ?thesis .
qed

lemma primitive_part_dvd_primitive_partI [intro]:
  fixes p q :: "'a :: {factorial_semiring, semiring_Gcd, ring_gcd, idom_divide} poly"
  shows "p dvd q \<Longrightarrow> primitive_part p dvd primitive_part q"
  by (auto elim!: dvdE simp: primitive_part_mult)

lemma content_prod_mset:
  fixes A :: "'a :: {factorial_semiring, semiring_Gcd} poly multiset"
  shows "content (prod_mset A) = prod_mset (image_mset content A)"
  by (induction A) (simp_all add: content_mult mult_ac)

lemma fract_poly_dvdD:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} poly"
  assumes "fract_poly p dvd fract_poly q" "content p = 1"
  shows   "p dvd q"
proof -
  from assms(1) obtain r where r: "fract_poly q = fract_poly p * r" by (erule dvdE)
  from content_decompose_fract[of r] guess c r' . note r' = this
  from r r' have eq: "fract_poly q = smult c (fract_poly (p * r'))" by simp
  from fract_poly_smult_eqE[OF this] guess a b . note ab = this
  have "content (smult a q) = content (smult b (p * r'))" by (simp only: ab(2))
  hence eq': "normalize b = a * content q" by (simp add: assms content_mult r' ab(4))
  have "1 = gcd a (normalize b)" by (simp add: ab)
  also note eq'
  also have "gcd a (a * content q) = a" by (simp add: gcd_proj1_if_dvd ab(4))
  finally have [simp]: "a = 1" by simp
  from eq ab have "q = p * ([:b:] * r')" by simp
  thus ?thesis by (rule dvdI)
qed

lemma content_prod_eq_1_iff:
  fixes p q :: "'a :: {factorial_semiring, semiring_Gcd} poly"
  shows "content (p * q) = 1 \<longleftrightarrow> content p = 1 \<and> content q = 1"
proof safe
  assume A: "content (p * q) = 1"
  {
    fix p q :: "'a poly" assume "content p * content q = 1"
    hence "1 = content p * content q" by simp
    hence "content p dvd 1" by (rule dvdI)
    hence "content p = 1" by simp
  } note B = this
  from A B[of p q] B [of q p] show "content p = 1" "content q = 1"
    by (simp_all add: content_mult mult_ac)
qed (auto simp: content_mult)

end

subsection \<open>Polynomials over a field are a Euclidean ring\<close>

definition unit_factor_field_poly :: "'a :: field poly \<Rightarrow> 'a poly" where
  "unit_factor_field_poly p = [:lead_coeff p:]"

definition normalize_field_poly :: "'a :: field poly \<Rightarrow> 'a poly" where
  "normalize_field_poly p = smult (inverse (lead_coeff p)) p"

definition euclidean_size_field_poly :: "'a :: field poly \<Rightarrow> nat" where
  "euclidean_size_field_poly p = (if p = 0 then 0 else 2 ^ degree p)"

lemma dvd_field_poly: "dvd.dvd (op * :: 'a :: field poly \<Rightarrow> _) = op dvd"
    by (intro ext) (simp_all add: dvd.dvd_def dvd_def)

interpretation field_poly:
  euclidean_ring where zero = "0 :: 'a :: field poly"
    and one = 1 and plus = plus and uminus = uminus and minus = minus
    and times = times
    and normalize = normalize_field_poly and unit_factor = unit_factor_field_poly
    and euclidean_size = euclidean_size_field_poly
    and divide = divide and modulo = modulo
proof (standard, unfold dvd_field_poly)
  fix p :: "'a poly"
  show "unit_factor_field_poly p * normalize_field_poly p = p"
    by (cases "p = 0")
       (simp_all add: unit_factor_field_poly_def normalize_field_poly_def lead_coeff_nonzero)
next
  fix p :: "'a poly" assume "is_unit p"
  thus "normalize_field_poly p = 1"
    by (elim is_unit_polyE) (auto simp: normalize_field_poly_def monom_0 one_poly_def field_simps)
next
  fix p :: "'a poly" assume "p \<noteq> 0"
  thus "is_unit (unit_factor_field_poly p)"
    by (simp add: unit_factor_field_poly_def lead_coeff_nonzero is_unit_pCons_iff)
qed (auto simp: unit_factor_field_poly_def normalize_field_poly_def lead_coeff_mult
       euclidean_size_field_poly_def Rings.div_mult_mod_eq intro!: degree_mod_less' degree_mult_right_le)

lemma field_poly_irreducible_imp_prime:
  assumes "irreducible (p :: 'a :: field poly)"
  shows   "prime_elem p"
proof -
  have A: "class.comm_semiring_1 op * 1 op + (0 :: 'a poly)" ..
  from field_poly.irreducible_imp_prime_elem[of p] assms
    show ?thesis unfolding irreducible_def prime_elem_def dvd_field_poly
      comm_semiring_1.irreducible_def[OF A] comm_semiring_1.prime_elem_def[OF A] by blast
qed

lemma field_poly_prod_mset_prime_factorization:
  assumes "(x :: 'a :: field poly) \<noteq> 0"
  shows   "prod_mset (field_poly.prime_factorization x) = normalize_field_poly x"
proof -
  have A: "class.comm_monoid_mult op * (1 :: 'a poly)" ..
  have "comm_monoid_mult.prod_mset op * (1 :: 'a poly) = prod_mset"
    by (intro ext) (simp add: comm_monoid_mult.prod_mset_def[OF A] prod_mset_def)
  with field_poly.prod_mset_prime_factorization[OF assms] show ?thesis by simp
qed

lemma field_poly_in_prime_factorization_imp_prime:
  assumes "(p :: 'a :: field poly) \<in># field_poly.prime_factorization x"
  shows   "prime_elem p"
proof -
  have A: "class.comm_semiring_1 op * 1 op + (0 :: 'a poly)" ..
  have B: "class.normalization_semidom op div op + op - (0 :: 'a poly) op * 1
             normalize_field_poly unit_factor_field_poly" ..
  from field_poly.in_prime_factors_imp_prime [of p x] assms
    show ?thesis unfolding prime_elem_def dvd_field_poly
      comm_semiring_1.prime_elem_def[OF A] normalization_semidom.prime_def[OF B] by blast
qed

subsection \<open>Primality and irreducibility in polynomial rings\<close>

lemma nonconst_poly_irreducible_iff:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} poly"
  assumes "degree p \<noteq> 0"
  shows   "irreducible p \<longleftrightarrow> irreducible (fract_poly p) \<and> content p = 1"
proof safe
  assume p: "irreducible p"

  from content_decompose[of p] guess p' . note p' = this
  hence "p = [:content p:] * p'" by simp
  from p this have "[:content p:] dvd 1 \<or> p' dvd 1" by (rule irreducibleD)
  moreover have "\<not>p' dvd 1"
  proof
    assume "p' dvd 1"
    hence "degree p = 0" by (subst p') (auto simp: is_unit_poly_iff)
    with assms show False by contradiction
  qed
  ultimately show [simp]: "content p = 1" by (simp add: is_unit_const_poly_iff)

  show "irreducible (map_poly to_fract p)"
  proof (rule irreducibleI)
    have "fract_poly p = 0 \<longleftrightarrow> p = 0" by (intro map_poly_eq_0_iff) auto
    with assms show "map_poly to_fract p \<noteq> 0" by auto
  next
    show "\<not>is_unit (fract_poly p)"
    proof
      assume "is_unit (map_poly to_fract p)"
      hence "degree (map_poly to_fract p) = 0"
        by (auto simp: is_unit_poly_iff)
      hence "degree p = 0" by (simp add: degree_map_poly)
      with assms show False by contradiction
   qed
 next
   fix q r assume qr: "fract_poly p = q * r"
   from content_decompose_fract[of q] guess cg q' . note q = this
   from content_decompose_fract[of r] guess cr r' . note r = this
   from qr q r p have nz: "cg \<noteq> 0" "cr \<noteq> 0" by auto
   from qr have eq: "fract_poly p = smult (cr * cg) (fract_poly (q' * r'))"
     by (simp add: q r)
   from fract_poly_smult_eqE[OF this] guess a b . note ab = this
   hence "content (smult a p) = content (smult b (q' * r'))" by (simp only:)
   with ab(4) have a: "a = normalize b" by (simp add: content_mult q r)
   hence "normalize b = gcd a b" by simp
   also from ab(3) have "\<dots> = 1" .
   finally have "a = 1" "is_unit b" by (simp_all add: a normalize_1_iff)

   note eq
   also from ab(1) \<open>a = 1\<close> have "cr * cg = to_fract b" by simp
   also have "smult \<dots> (fract_poly (q' * r')) = fract_poly (smult b (q' * r'))" by simp
   finally have "p = ([:b:] * q') * r'" by (simp del: fract_poly_smult)
   from p and this have "([:b:] * q') dvd 1 \<or> r' dvd 1" by (rule irreducibleD)
   hence "q' dvd 1 \<or> r' dvd 1" by (auto dest: dvd_mult_right simp del: mult_pCons_left)
   hence "fract_poly q' dvd 1 \<or> fract_poly r' dvd 1" by (auto simp: fract_poly_is_unit)
   with q r show "is_unit q \<or> is_unit r"
     by (auto simp add: is_unit_smult_iff dvd_field_iff nz)
 qed

next

  assume irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
  show "irreducible p"
  proof (rule irreducibleI)
    from irred show "p \<noteq> 0" by auto
  next
    from irred show "\<not>p dvd 1"
      by (auto simp: irreducible_def dest: fract_poly_is_unit)
  next
    fix q r assume qr: "p = q * r"
    hence "fract_poly p = fract_poly q * fract_poly r" by simp
    from irred and this have "fract_poly q dvd 1 \<or> fract_poly r dvd 1"
      by (rule irreducibleD)
    with primitive qr show "q dvd 1 \<or> r dvd 1"
      by (auto simp:  content_prod_eq_1_iff is_unit_fract_poly_iff)
  qed
qed

context
begin

private lemma irreducible_imp_prime_poly:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} poly"
  assumes "irreducible p"
  shows   "prime_elem p"
proof (cases "degree p = 0")
  case True
  with assms show ?thesis
    by (auto simp: prime_elem_const_poly_iff irreducible_const_poly_iff
             intro!: irreducible_imp_prime_elem elim!: degree_eq_zeroE)
next
  case False
  from assms False have irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
    by (simp_all add: nonconst_poly_irreducible_iff)
  from irred have prime: "prime_elem (fract_poly p)" by (rule field_poly_irreducible_imp_prime)
  show ?thesis
  proof (rule prime_elemI)
    fix q r assume "p dvd q * r"
    hence "fract_poly p dvd fract_poly (q * r)" by (rule fract_poly_dvd)
    hence "fract_poly p dvd fract_poly q * fract_poly r" by simp
    from prime and this have "fract_poly p dvd fract_poly q \<or> fract_poly p dvd fract_poly r"
      by (rule prime_elem_dvd_multD)
    with primitive show "p dvd q \<or> p dvd r" by (auto dest: fract_poly_dvdD)
  qed (insert assms, auto simp: irreducible_def)
qed

lemma degree_primitive_part_fract [simp]:
  "degree (primitive_part_fract p) = degree p"
proof -
  have "p = smult (fract_content p) (fract_poly (primitive_part_fract p))"
    by (simp add: content_times_primitive_part_fract)
  also have "degree \<dots> = degree (primitive_part_fract p)"
    by (auto simp: degree_map_poly)
  finally show ?thesis ..
qed

lemma irreducible_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd} fract poly"
  assumes "irreducible p"
  shows   "irreducible (primitive_part_fract p)"
proof -
  from assms have deg: "degree (primitive_part_fract p) \<noteq> 0"
    by (intro notI)
       (auto elim!: degree_eq_zeroE simp: irreducible_def is_unit_poly_iff dvd_field_iff)
  hence [simp]: "p \<noteq> 0" by auto

  note \<open>irreducible p\<close>
  also have "p = [:fract_content p:] * fract_poly (primitive_part_fract p)"
    by (simp add: content_times_primitive_part_fract)
  also have "irreducible \<dots> \<longleftrightarrow> irreducible (fract_poly (primitive_part_fract p))"
    by (intro irreducible_mult_unit_left) (simp_all add: is_unit_poly_iff dvd_field_iff)
  finally show ?thesis using deg
    by (simp add: nonconst_poly_irreducible_iff)
qed

lemma prime_elem_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd} fract poly"
  shows "irreducible p \<Longrightarrow> prime_elem (primitive_part_fract p)"
  by (intro irreducible_imp_prime_poly irreducible_primitive_part_fract)

lemma irreducible_linear_field_poly:
  fixes a b :: "'a::field"
  assumes "b \<noteq> 0"
  shows "irreducible [:a,b:]"
proof (rule irreducibleI)
  fix p q assume pq: "[:a,b:] = p * q"
  also from pq assms have "degree \<dots> = degree p + degree q"
    by (intro degree_mult_eq) auto
  finally have "degree p = 0 \<or> degree q = 0" using assms by auto
  with assms pq show "is_unit p \<or> is_unit q"
    by (auto simp: is_unit_const_poly_iff dvd_field_iff elim!: degree_eq_zeroE)
qed (insert assms, auto simp: is_unit_poly_iff)

lemma prime_elem_linear_field_poly:
  "(b :: 'a :: field) \<noteq> 0 \<Longrightarrow> prime_elem [:a,b:]"
  by (rule field_poly_irreducible_imp_prime, rule irreducible_linear_field_poly)

lemma irreducible_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> irreducible [:a,b:]"
  by (auto intro!: irreducible_linear_field_poly
           simp:   nonconst_poly_irreducible_iff content_def map_poly_pCons)

lemma prime_elem_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> prime_elem [:a,b:]"
  by (rule irreducible_imp_prime_poly, rule irreducible_linear_poly)

end

subsection \<open>Prime factorisation of polynomials\<close>

context
begin

private lemma poly_prime_factorization_exists_content_1:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} poly"
  assumes "p \<noteq> 0" "content p = 1"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize p"
proof -
  let ?P = "field_poly.prime_factorization (fract_poly p)"
  define c where "c = prod_mset (image_mset fract_content ?P)"
  define c' where "c' = c * to_fract (lead_coeff p)"
  define e where "e = prod_mset (image_mset primitive_part_fract ?P)"
  define A where "A = image_mset (normalize \<circ> primitive_part_fract) ?P"
  have "content e = (\<Prod>x\<in>#field_poly.prime_factorization (map_poly to_fract p).
                      content (primitive_part_fract x))"
    by (simp add: e_def content_prod_mset multiset.map_comp o_def)
  also have "image_mset (\<lambda>x. content (primitive_part_fract x)) ?P = image_mset (\<lambda>_. 1) ?P"
    by (intro image_mset_cong content_primitive_part_fract) auto
  finally have content_e: "content e = 1" by (simp add: prod_mset_const)

  have "fract_poly p = unit_factor_field_poly (fract_poly p) *
          normalize_field_poly (fract_poly p)" by simp
  also have "unit_factor_field_poly (fract_poly p) = [:to_fract (lead_coeff p):]"
    by (simp add: unit_factor_field_poly_def lead_coeff_def monom_0 degree_map_poly coeff_map_poly)
  also from assms have "normalize_field_poly (fract_poly p) = prod_mset ?P"
    by (subst field_poly_prod_mset_prime_factorization) simp_all
  also have "\<dots> = prod_mset (image_mset id ?P)" by simp
  also have "image_mset id ?P =
               image_mset (\<lambda>x. [:fract_content x:] * fract_poly (primitive_part_fract x)) ?P"
    by (intro image_mset_cong) (auto simp: content_times_primitive_part_fract)
  also have "prod_mset \<dots> = smult c (fract_poly e)"
    by (subst prod_mset_mult) (simp_all add: prod_mset_fract_poly prod_mset_const_poly c_def e_def)
  also have "[:to_fract (lead_coeff p):] * \<dots> = smult c' (fract_poly e)"
    by (simp add: c'_def)
  finally have eq: "fract_poly p = smult c' (fract_poly e)" .
  also obtain b where b: "c' = to_fract b" "is_unit b"
  proof -
    from fract_poly_smult_eqE[OF eq] guess a b . note ab = this
    from ab(2) have "content (smult a p) = content (smult b e)" by (simp only: )
    with assms content_e have "a = normalize b" by (simp add: ab(4))
    with ab have ab': "a = 1" "is_unit b" by (simp_all add: normalize_1_iff)
    with ab ab' have "c' = to_fract b" by auto
    from this and \<open>is_unit b\<close> show ?thesis by (rule that)
  qed
  hence "smult c' (fract_poly e) = fract_poly (smult b e)" by simp
  finally have "p = smult b e" by (simp only: fract_poly_eq_iff)
  hence "p = [:b:] * e" by simp
  with b have "normalize p = normalize e"
    by (simp only: normalize_mult) (simp add: is_unit_normalize is_unit_poly_iff)
  also have "normalize e = prod_mset A"
    by (simp add: multiset.map_comp e_def A_def normalize_prod_mset)
  finally have "prod_mset A = normalize p" ..

  have "prime_elem p" if "p \<in># A" for p
    using that by (auto simp: A_def prime_elem_primitive_part_fract prime_elem_imp_irreducible
                        dest!: field_poly_in_prime_factorization_imp_prime )
  from this and \<open>prod_mset A = normalize p\<close> show ?thesis
    by (intro exI[of _ A]) blast
qed

lemma poly_prime_factorization_exists:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide} poly"
  assumes "p \<noteq> 0"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize p"
proof -
  define B where "B = image_mset (\<lambda>x. [:x:]) (prime_factorization (content p))"
  have "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize (primitive_part p)"
    by (rule poly_prime_factorization_exists_content_1) (insert assms, simp_all)
  then guess A by (elim exE conjE) note A = this
  moreover from assms have "prod_mset B = [:content p:]"
    by (simp add: B_def prod_mset_const_poly prod_mset_prime_factorization)
  moreover have "\<forall>p. p \<in># B \<longrightarrow> prime_elem p"
    by (auto simp: B_def intro!: lift_prime_elem_poly dest: in_prime_factors_imp_prime)
  ultimately show ?thesis by (intro exI[of _ "B + A"]) auto
qed

end

subsection \<open>Typeclass instances\<close>

instance poly :: (factorial_ring_gcd) factorial_semiring
  by standard (rule poly_prime_factorization_exists)

instantiation poly :: (factorial_ring_gcd) factorial_ring_gcd
begin

definition gcd_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "gcd_poly = gcd_factorial"

definition lcm_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "lcm_poly = lcm_factorial"

definition Gcd_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Gcd_poly = Gcd_factorial"

definition Lcm_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Lcm_poly = Lcm_factorial"

instance by standard (simp_all add: gcd_poly_def lcm_poly_def Gcd_poly_def Lcm_poly_def)

end

instantiation poly :: ("{field,factorial_ring_gcd}") euclidean_ring
begin

definition euclidean_size_poly :: "'a poly \<Rightarrow> nat" where
  "euclidean_size_poly p = (if p = 0 then 0 else 2 ^ degree p)"

instance
  by standard (auto simp: euclidean_size_poly_def Rings.div_mult_mod_eq intro!: degree_mod_less' degree_mult_right_le)
end

instance poly :: ("{field,factorial_ring_gcd}") euclidean_ring_gcd
  by standard (simp_all add: gcd_poly_def lcm_poly_def Gcd_poly_def Lcm_poly_def eucl_eq_factorial)

subsection \<open>Polynomial GCD\<close>

lemma gcd_poly_decompose:
  fixes p q :: "'a :: factorial_ring_gcd poly"
  shows "gcd p q =
           smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
proof (rule sym, rule gcdI)
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content p:] * primitive_part p" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd p"
    by simp
next
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content q:] * primitive_part q" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd q"
    by simp
next
  fix d assume "d dvd p" "d dvd q"
  hence "[:content d:] * primitive_part d dvd
           [:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q)"
    by (intro mult_dvd_mono) auto
  thus "d dvd smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
    by simp
qed (auto simp: normalize_smult)

lemma gcd_poly_pseudo_mod:
  fixes p q :: "'a :: factorial_ring_gcd poly"
  assumes nz: "q \<noteq> 0" and prim: "content p = 1" "content q = 1"
  shows   "gcd p q = gcd q (primitive_part (pseudo_mod p q))"
proof -
  define r s where "r = fst (pseudo_divmod p q)" and "s = snd (pseudo_divmod p q)"
  define a where "a = [:coeff q (degree q) ^ (Suc (degree p) - degree q):]"
  have [simp]: "primitive_part a = unit_factor a"
    by (simp add: a_def unit_factor_poly_def unit_factor_power monom_0)
  from nz have [simp]: "a \<noteq> 0" by (auto simp: a_def)

  have rs: "pseudo_divmod p q = (r, s)" by (simp add: r_def s_def)
  have "gcd (q * r + s) q = gcd q s"
    using gcd_add_mult[of q r s] by (simp add: gcd.commute add_ac mult_ac)
  with pseudo_divmod(1)[OF nz rs]
    have "gcd (p * a) q = gcd q s" by (simp add: a_def)
  also from prim have "gcd (p * a) q = gcd p q"
    by (subst gcd_poly_decompose)
       (auto simp: primitive_part_mult gcd_mult_unit1 primitive_part_prim
             simp del: mult_pCons_right )
  also from prim have "gcd q s = gcd q (primitive_part s)"
    by (subst gcd_poly_decompose) (simp_all add: primitive_part_prim)
  also have "s = pseudo_mod p q" by (simp add: s_def pseudo_mod_def)
  finally show ?thesis .
qed

lemma degree_pseudo_mod_less:
  assumes "q \<noteq> 0" "pseudo_mod p q \<noteq> 0"
  shows   "degree (pseudo_mod p q) < degree q"
  using pseudo_mod(2)[of q p] assms by auto

function gcd_poly_code_aux :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "gcd_poly_code_aux p q =
     (if q = 0 then normalize p else gcd_poly_code_aux q (primitive_part (pseudo_mod p q)))"
by auto
termination
  by (relation "measure ((\<lambda>p. if p = 0 then 0 else Suc (degree p)) \<circ> snd)")
     (auto simp: degree_pseudo_mod_less)

declare gcd_poly_code_aux.simps [simp del]

lemma gcd_poly_code_aux_correct:
  assumes "content p = 1" "q = 0 \<or> content q = 1"
  shows   "gcd_poly_code_aux p q = gcd p q"
  using assms
proof (induction p q rule: gcd_poly_code_aux.induct)
  case (1 p q)
  show ?case
  proof (cases "q = 0")
    case True
    thus ?thesis by (subst gcd_poly_code_aux.simps) auto
  next
    case False
    hence "gcd_poly_code_aux p q = gcd_poly_code_aux q (primitive_part (pseudo_mod p q))"
      by (subst gcd_poly_code_aux.simps) simp_all
    also from "1.prems" False
      have "primitive_part (pseudo_mod p q) = 0 \<or>
              content (primitive_part (pseudo_mod p q)) = 1"
      by (cases "pseudo_mod p q = 0") auto
    with "1.prems" False
      have "gcd_poly_code_aux q (primitive_part (pseudo_mod p q)) =
              gcd q (primitive_part (pseudo_mod p q))"
      by (intro 1) simp_all
    also from "1.prems" False
      have "\<dots> = gcd p q" by (intro gcd_poly_pseudo_mod [symmetric]) auto
    finally show ?thesis .
  qed
qed

definition gcd_poly_code
    :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
  where "gcd_poly_code p q =
           (if p = 0 then normalize q else if q = 0 then normalize p else
              smult (gcd (content p) (content q))
                (gcd_poly_code_aux (primitive_part p) (primitive_part q)))"

lemma lcm_poly_code [code]:
  fixes p q :: "'a :: factorial_ring_gcd poly"
  shows "lcm p q = normalize (p * q) div gcd p q"
  by (rule lcm_gcd)

lemma gcd_poly_code [code]: "gcd p q = gcd_poly_code p q"
  by (simp add: gcd_poly_code_def gcd_poly_code_aux_correct gcd_poly_decompose [symmetric])

declare Gcd_set
  [where ?'a = "'a :: factorial_ring_gcd poly", code]

declare Lcm_set
  [where ?'a = "'a :: factorial_ring_gcd poly", code]

value [code] "Lcm {[:1,2,3:], [:2,3,4::int poly:]}"

end


section\<open>The main theorem\<close>
theory Forcing_Main
  imports
  Internal_ZFC_Axioms
  Choice_Axiom
  Ordinals_In_MG
  Succession_Poset

begin

subsection\<open>The generic extension is countable\<close>
(*
\<comment> \<open>Useful missing lemma\<close>
lemma surj_imp_well_ord:
  assumes "well_ord(A,r)" "h \<in> surj(A,B)"
  shows "\<exists>s. well_ord(B,r)"
*)

definition
  minimum :: "i \<Rightarrow> i \<Rightarrow> i" where
  "minimum(r,B) \<equiv> THE b. b\<in>B \<and> (\<forall>y\<in>B. y \<noteq> b \<longrightarrow> \<langle>b, y\<rangle> \<in> r)"

lemma well_ord_imp_min:
  assumes
    "well_ord(A,r)" "B \<subseteq> A" "B \<noteq> 0"
  shows
    "minimum(r,B) \<in> B"
proof -
  from \<open>well_ord(A,r)\<close>
  have "wf[A](r)"
    using well_ord_is_wf[OF \<open>well_ord(A,r)\<close>] by simp
  with \<open>B\<subseteq>A\<close>
  have "wf[B](r)"
    using Sigma_mono Int_mono wf_subset unfolding wf_on_def by simp
  then
  have "\<forall> x. x \<in> B \<longrightarrow> (\<exists>z\<in>B. \<forall>y. \<langle>y, z\<rangle> \<in> r\<inter>B\<times>B \<longrightarrow> y \<notin> B)"
    unfolding wf_on_def using wf_eq_minimal
    by blast
  with \<open>B\<noteq>0\<close>
  obtain z where
    B: "z\<in>B \<and> (\<forall>y. \<langle>y,z\<rangle>\<in>r\<inter>B\<times>B \<longrightarrow> y\<notin>B)"
    by blast
  then
  have "z\<in>B \<and> (\<forall>y\<in>B. y \<noteq> z \<longrightarrow> \<langle>z, y\<rangle> \<in> r)"
  proof -
    {
      fix y
      assume "y\<in>B" "y\<noteq>z"
      with \<open>well_ord(A,r)\<close> B \<open>B\<subseteq>A\<close>
      have "\<langle>z,y\<rangle>\<in>r|\<langle>y,z\<rangle>\<in>r|y=z"
        unfolding well_ord_def tot_ord_def linear_def by auto
      with B \<open>y\<in>B\<close> \<open>y\<noteq>z\<close>
      have "\<langle>z,y\<rangle>\<in>r"
        by (cases;auto)
    }
    with B
    show ?thesis by blast
  qed
  have "v = z" if "v\<in>B \<and> (\<forall>y\<in>B. y \<noteq> v \<longrightarrow> \<langle>v, y\<rangle> \<in> r)" for v
    using that B by auto
  with \<open>z\<in>B \<and> (\<forall>y\<in>B. y \<noteq> z \<longrightarrow> \<langle>z, y\<rangle> \<in> r)\<close>
  show ?thesis
    unfolding minimum_def
    using the_equality2[OF ex1I[of "\<lambda>x .x\<in>B \<and> (\<forall>y\<in>B. y \<noteq> x \<longrightarrow> \<langle>x, y\<rangle> \<in> r)" z]]
    by auto
qed

lemma well_ord_surj_imp_lepoll:
  assumes "well_ord(A,r)" "h \<in> surj(A,B)"
  shows "B \<lesssim> A"
proof -
  let ?f="\<lambda>b\<in>B. minimum(r, {a\<in>A. h`a=b})"
  have "b \<in> B \<Longrightarrow> minimum(r, {a \<in> A . h ` a = b}) \<in> {a\<in>A. h`a=b}" for b
  proof -
    fix b
    assume "b\<in>B"
    with \<open>h \<in> surj(A,B)\<close>
    have "\<exists>a\<in>A. h`a=b"
      unfolding surj_def by blast
    then
    have "{a\<in>A. h`a=b} \<noteq> 0"
      by auto
    with assms
    show "minimum(r,{a\<in>A. h`a=b}) \<in> {a\<in>A. h`a=b}"
      using well_ord_imp_min by blast
  qed
  moreover from this
  have "?f : B \<rightarrow> A"
      using lam_type[of B _ "\<lambda>_.A"] by simp
  moreover
  have "?f ` w = ?f ` x \<Longrightarrow> w = x" if "w\<in>B" "x\<in>B" for w x
  proof -
    from calculation(1)[OF that(1)] calculation(1)[OF that(2)]
    have "w = h ` minimum(r, {a \<in> A . h ` a = w})"
         "x = h ` minimum(r, {a \<in> A . h ` a = x})"
      by simp_all
    moreover
    assume "?f ` w = ?f ` x"
    moreover from this and that
    have "minimum(r, {a \<in> A . h ` a = w}) = minimum(r, {a \<in> A . h ` a = x})"
      by simp_all
    moreover from calculation(1,2,4)
    show "w=x" by simp
    qed
  ultimately
  show ?thesis
  unfolding lepoll_def inj_def by blast
qed

lemma (in forcing_data) surj_nat_MG :
  "\<exists>f. f \<in> surj(nat,M[G])"
proof -
  let ?f="\<lambda>n\<in>nat. val(G,enum`n)"
  have "x \<in> nat \<Longrightarrow> val(G, enum ` x)\<in> M[G]" for x
    using GenExtD[THEN iffD2, of _ G] bij_is_fun[OF M_countable] by force
  then
  have "?f: nat \<rightarrow> M[G]"
    using lam_type[of nat "\<lambda>n. val(G,enum`n)" "\<lambda>_.M[G]"] by simp
  moreover
  have "\<exists>n\<in>nat. ?f`n = x" if "x\<in>M[G]" for x
    using that GenExtD[of _ G] bij_is_surj[OF M_countable]
    unfolding surj_def by auto
  ultimately
  show ?thesis
    unfolding surj_def by blast
qed

lemma (in G_generic) MG_eqpoll_nat: "M[G] \<approx> nat"
proof -
  interpret MG: M_ZF_trans "M[G]"
    using Transset_MG generic pairing_in_MG
      Union_MG  extensionality_in_MG power_in_MG
      foundation_in_MG  strong_replacement_in_MG[simplified]
      separation_in_MG[simplified] infinity_in_MG
    by unfold_locales simp_all
  obtain f where "f \<in> surj(nat,M[G])"
    using surj_nat_MG by blast
  then
  have "M[G] \<lesssim> nat"
    using well_ord_surj_imp_lepoll well_ord_Memrel[of nat]
    by simp
  moreover
  have "nat \<lesssim> M[G]"
    using MG.nat_into_M subset_imp_lepoll by auto
  ultimately
  show ?thesis using eqpollI
    by simp
qed

subsection\<open>The main result\<close>

theorem extensions_of_ctms:
  assumes
    "M \<approx> nat" "Transset(M)" "M \<Turnstile> ZF"
  shows
    "\<exists>N.
      M \<subseteq> N \<and> N \<approx> nat \<and> Transset(N) \<and> N \<Turnstile> ZF \<and> M\<noteq>N \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)) \<and>
      (M, []\<Turnstile> AC \<longrightarrow> N \<Turnstile> ZFC)"
proof -
  from \<open>M \<approx> nat\<close>
  obtain enum where "enum \<in> bij(nat,M)"
    using eqpoll_sym unfolding eqpoll_def by blast
  with assms
  interpret M_ctm M enum
    using M_ZF_iff_M_satT
    by intro_locales (simp_all add:M_ctm_axioms_def)
  interpret ctm_separative "2^<\<omega>" seqle 0 M enum
  proof (unfold_locales)
    fix f
    let ?q="seq_upd(f,0)" and ?r="seq_upd(f,1)"
    assume "f \<in> 2^<\<omega>"
    then
    have "?q \<preceq>s f \<and> ?r \<preceq>s f \<and> ?q \<bottom>s ?r"
      using upd_leI seqspace_separative by auto
    moreover from calculation
    have "?q \<in> 2^<\<omega>"  "?r \<in> 2^<\<omega>"
      using seq_upd_type[of f 2] by auto
    ultimately
    show "\<exists>q\<in>2^<\<omega>.  \<exists>r\<in>2^<\<omega>. q \<preceq>s f \<and> r \<preceq>s f \<and> q \<bottom>s r"
      by (rule_tac bexI)+ \<comment> \<open>why the heck auto-tools don't solve this?\<close>
  next
    show "2^<\<omega> \<in> M" using nat_into_M seqspace_closed by simp
  next
    show "seqle \<in> M" using seqle_in_M .
  qed
  from cohen_extension_is_proper
  obtain G where "M_generic(G)"
    "M \<noteq> GenExt(G)" (is "M\<noteq>?N")
    by blast
  then
  interpret G_generic "2^<\<omega>" seqle 0 _ enum G by unfold_locales
  interpret MG: M_ZF "?N"
    using generic pairing_in_MG
      Union_MG  extensionality_in_MG power_in_MG
      foundation_in_MG  strong_replacement_in_MG[simplified]
      separation_in_MG[simplified] infinity_in_MG
    by unfold_locales simp_all
  have "?N \<Turnstile> ZF"
    using M_ZF_iff_M_satT[of ?N] MG.M_ZF_axioms by simp
  moreover
  have "M, []\<Turnstile> AC \<Longrightarrow> ?N \<Turnstile> ZFC"
  proof -
    assume "M, [] \<Turnstile> AC"
    then
    have "choice_ax(##M)"
      unfolding ZF_choice_fm_def using ZF_choice_auto by simp
    then
    have "choice_ax(##?N)" using choice_in_MG by simp
    with \<open>?N \<Turnstile> ZF\<close>
    show "?N \<Turnstile> ZFC"
      using ZF_choice_auto sats_ZFC_iff_sats_ZF_AC
      unfolding ZF_choice_fm_def by simp
  qed
  moreover
  note \<open>M \<noteq> ?N\<close>
  moreover
  have "Transset(?N)" using Transset_MG .
  moreover
  have "M \<subseteq> ?N" using M_subset_MG[OF one_in_G] generic by simp
  ultimately
  show ?thesis
    using Ord_MG_iff MG_eqpoll_nat
    by (rule_tac x="?N" in exI, simp)
qed

end


theory IP_Address_toString
imports IP_Address IPv4 IPv6
        Lib_Word_toString
        Lib_List_toString
        "HOL-Library.Code_Target_Nat" (*!!*)
begin

section\<open>Pretty Printing IP Addresses\<close>

subsection\<open>Generic Pretty Printer\<close>

  text\<open>Generic function. Whenever possible, use IPv4 or IPv6 pretty printing!\<close>
  definition ipaddr_generic_toString :: "'i::len word \<Rightarrow> string" where
    "ipaddr_generic_toString ip \<equiv>
      ''[IP address ('' @ string_of_nat (LENGTH('i)) @ '' bit): '' @ dec_string_of_word0 ip @ '']''"

  lemma "ipaddr_generic_toString (ipv4addr_of_dotdecimal (192,168,0,1)) = ''[IP address (32 bit): 3232235521]''" by eval

subsection\<open>IPv4 Pretty Printing\<close>

  fun dotteddecimal_toString :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> string" where
    "dotteddecimal_toString (a,b,c,d) =
      string_of_nat a@''.''@string_of_nat b@''.''@string_of_nat c@''.''@string_of_nat d"

  definition ipv4addr_toString :: "ipv4addr \<Rightarrow> string" where
    "ipv4addr_toString ip = dotteddecimal_toString (dotdecimal_of_ipv4addr ip)"

  lemma "ipv4addr_toString (ipv4addr_of_dotdecimal (192, 168, 0, 1)) = ''192.168.0.1''" by eval

  text\<open>Correctness Theorems:\<close>
  thm dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal
      ipv4addr_of_dotdecimal_dotdecimal_of_ipv4addr

subsection\<open>IPv6 Pretty Printing\<close>

  definition ipv6addr_toString :: "ipv6addr \<Rightarrow> string" where
    "ipv6addr_toString ip = (
      let partslist = ipv6_preferred_to_compressed (int_to_ipv6preferred ip);
          \<comment> \<open>add empty lists to the beginning and end if omission occurs at start/end\<close>
          \<comment> \<open>to join over \<^verbatim>\<open>:\<close> properly\<close>
          fix_start = (\<lambda>ps. case ps of None#_ \<Rightarrow> None#ps | _ \<Rightarrow> ps);
          fix_end = (\<lambda>ps. case rev ps of None#_ \<Rightarrow> ps@[None] | _ \<Rightarrow> ps)
      in list_separated_toString '':''
        (\<lambda>pt. case pt of None \<Rightarrow> ''''
                      |  Some w \<Rightarrow> hex_string_of_word0 w)
        ((fix_end \<circ> fix_start) partslist)
      )"

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0x2001 0xDB8 0x0 0x0 0x8 0x800 0x200C 0x417A))
              = ''2001:db8::8:800:200c:417a''" by eval \<comment> \<open>a unicast address\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0xFF01 0x0 0x0 0x0 0x0 0x0 0x0 0x0101)) =
              ''ff01::101''" by eval \<comment> \<open>a multicast address\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0 0 0 0 0x8 0x800 0x200C 0x417A)) =
               ''::8:800:200c:417a''" by eval

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0x2001 0xDB8 0 0 0 0 0 0)) =
               ''2001:db8::''" by eval

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0xFF00 0 0 0 0 0 0 0)) =
               ''ff00::''" by eval \<comment> \<open>Multicast\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0xFE80 0 0 0 0 0 0 0)) =
               ''fe80::''" by eval \<comment> \<open>Link-Local unicast\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0 0 0 0 0 0 0 0)) =
               ''::''" by eval \<comment> \<open>unspecified address\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int (IPv6AddrPreferred 0 0 0 0 0 0 0 1)) =
               ''::1''" by eval \<comment> \<open>loopback address\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int
          (IPv6AddrPreferred 0x2001 0xdb8 0x0 0x0 0x0 0x0 0x0 0x1)) =
              ''2001:db8::1''" by eval \<comment> \<open>Section 4.1 of RFC5952\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int
          (IPv6AddrPreferred 0x2001 0xdb8 0x0 0x0 0x0 0x0 0x2 0x1)) =
              ''2001:db8::2:1''" by eval \<comment> \<open>Section 4.2.1 of RFC5952\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int
          (IPv6AddrPreferred 0x2001 0xdb8 0x0 0x1 0x1 0x1 0x1 0x1)) =
              ''2001:db8:0:1:1:1:1:1''" by eval \<comment> \<open>Section 4.2.2 of RFC5952\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int
          (IPv6AddrPreferred 0x2001 0x0 0x0 0x1 0x0 0x0 0x0 0x1)) =
              ''2001:0:0:1::1''" by eval \<comment> \<open>Section 4.2.3 of RFC5952\<close>

  lemma "ipv6addr_toString (ipv6preferred_to_int
          (IPv6AddrPreferred 0x2001 0xdb8 0x0 0x0 0x1 0x0 0x0 0x1)) =
              ''2001:db8::1:0:0:1''" by eval \<comment> \<open>Section 4.2.3 of RFC5952\<close>

  lemma "ipv6addr_toString max_ipv6_addr = ''ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff''" by eval
  lemma "ipv6addr_toString (ipv6preferred_to_int
           (IPv6AddrPreferred 0xffff 0xffff 0xffff 0xffff 0xffff 0xffff 0xffff 0xffff)) =
              ''ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff''" by eval

  text\<open>Correctness Theorems:\<close>
  thm ipv6_preferred_to_compressed
      ipv6_preferred_to_compressed_RFC_4291_format
      ipv6_unparsed_compressed_to_preferred_identity1
      ipv6_unparsed_compressed_to_preferred_identity2
      RFC_4291_format
      ipv6preferred_to_int_int_to_ipv6preferred
      int_to_ipv6preferred_ipv6preferred_to_int

end


section "Abstract nonstandard semantics"

theory AbsCF
  imports HOLCF HOLCFUtils CPSScheme Utils SetMap
begin

default_sort type

text \<open>
After having defined the exact meaning of a control graph, we now alter the algorithm into a statically computable. We note that the contour pointer in the exact semantics is taken from an infinite set. This is unavoidable, as recursion depth is unbounded. But if this were not the case and the set were finite, the function would be calculable, having finite range and domain.

Therefore, we make the set of contour counter values finite and accept that this makes our result less exact, but calculable. We also do not work with values any more but only remember, for each variable, what possible lambdas can occur there. Because we do not have exact values any more, in a conditional expression, both branches are taken.

We want to leave the exact choice of the finite contour set open for now. Therefore, we define a type class capturing the relevant definitions and the fact that the set is finite. Isabelle expects type classes to be non-empty, so we show that the \<open>unit\<close> type is in this type class.
\<close>

class contour = finite +
  fixes nb_a :: "'a \<Rightarrow> label \<Rightarrow> 'a" ("\<anb>")
    and a_initial_contour :: 'a ("\<abinit>")

instantiation unit :: contour
begin
definition "\<anb> _ _ = ()"
definition "\<abinit> = ()"
instance by standard auto
end

text \<open>
Analogous to the previous section, we define types for binding environments, closures, procedures, semantic values (which are now sets of possible procedures) and variable environment. Their types are parametrized by the chosen set of abstract contours.

The abstract variable environment is a partial map to sets in Shivers' dissertation. As he does not need to distinguish between a key not in the map and a key mapped to the empty set, this presentation is redundant. Therefore, I encoded this as a function from keys to sets of values. The theory @{theory "Shivers-CFA.SetMap"} contains functions and lemmas to work with such maps, symbolized by an appended dot (e.g. \<open>{}.\<close>, \<open>\<union>.\<close>).
\<close>

type_synonym 'c a_benv = "label \<rightharpoonup> 'c" ("_ \<abenv>" [1000])
type_synonym 'c a_closure = "lambda \<times> 'c \<abenv>" ("_ \<aclosure>" [1000])

datatype 'c proc ("_ \<aproc>" [1000])
  = PC "'c \<aclosure>"
  | PP prim
  | AStop

type_synonym 'c a_d = "'c \<aproc> set" ("_ \<ad>" [1000])

type_synonym 'c a_venv = "var \<times> 'c \<Rightarrow> 'c \<ad>" ("_ \<avenv>" [1000])

text \<open>
The evaluation function now ignores constants and returns singletons for primitive operations and lambda expressions.
\<close>

fun evalV_a :: "val \<Rightarrow> 'c \<abenv> \<Rightarrow> 'c \<avenv> \<Rightarrow> 'c \<ad>" ("\<aA>")
  where "\<aA> (C _ i) \<beta> ve = {}"
  |     "\<aA> (P prim) \<beta> ve = {PP prim}"
  |     "\<aA> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> ve (var,l)
            | None \<Rightarrow> {})"
  |     "\<aA> (L lam) \<beta> ve = {PC (lam, \<beta>)}"

text \<open>
The types of the calculated graph, the arguments to \<open>\<aF>\<close> and \<open>\<aC>\<close> resemble closely the types in the exact case, with each type replaced by its abstract counterpart.
\<close>

type_synonym 'c a_ccache = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>) set" ("_ \<accache>" [1000])
type_synonym 'c a_ans = "'c \<accache>" ("_ \<aans>" [1000])

type_synonym 'c a_fstate = "('c \<aproc> \<times> 'c \<ad> list \<times> 'c \<avenv> \<times> 'c)" ("_ \<afstate>" [1000])
type_synonym 'c a_cstate = "(call \<times> 'c \<abenv> \<times> 'c \<avenv> \<times> 'c)" ("_ \<acstate>" [1000])

text \<open>
And yet again, cont2cont results need to be shown for our custom data types.
\<close>

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_proc [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "cont (\<lambda>x. f3 x)"
  shows "cont (\<lambda>x. case_proc (f1 x) (f2 x) (f3 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text \<open>
We can now define the abstract nonstandard semantics, based on the equations in Figure 4.5 and 4.6 of Shivers' dissertation. In the \<open>AStop\<close> case, \<open>{}\<close> is returned, while for wrong arguments, \<open>\<bottom>\<close> is returned. Both actually represent the same value, the empty set, so this is just a aesthetic difference.
\<close>

fixrec   a_evalF :: "'c::contour \<afstate> discr \<rightarrow> 'c \<aans>" ("\<aF>")
     and a_evalC :: "'c::contour \<acstate> discr \<rightarrow> 'c \<aans>" ("\<aC>")
  where "\<aF>\<cdot>fstate = (case undiscr fstate of
             (PC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,a). {(v,b) := a}.) (zip vs as)))
                     in \<aC>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (PP (Plus c),[_,_,cnts],ve,b) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in (\<Union>cnt\<in>cnts. \<aF>\<cdot>(Discr (cnt,[{}],ve,b')))
                        \<union>
                        {((c, \<beta>), cont) | cont . cont \<in> cnts}
            | (PP (prim.If ct cf),[_, cntts, cntfs],ve,b) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<Union>cnt\<in>cntts . \<aF>\<cdot>(Discr (cnt,[],ve,b')))
                           \<union>{((ct, \<beta>), cnt) | cnt . cnt \<in> cntts}
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<Union>cnt\<in>cntfs . \<aF>\<cdot>(Discr (cnt,[],ve,b')))
                           \<union>{((cf, \<beta>), cnt) | cnt . cnt \<in> cntfs}
                   ))
            | (AStop,[_],_,_) \<Rightarrow> {}
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<aC>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in (\<Union>f' \<in> fs. \<aF>\<cdot>(Discr (f',as,ve,b')))
                     \<union>{((lab, \<beta>),f') | f' . f'\<in> fs}
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = \<anb> b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                     ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,l). {(v,b') := (\<aA> (L l) \<beta>' ve)}.) ls))
                 in \<aC>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text \<open>
Again, we name the cases of the induction rule and build a nicer case analysis rule for arguments of type \<open>\<afstate>\<close>.
\<close>

lemmas a_evalF_evalC_induct = a_evalF_a_evalC.induct[case_names Admissibility Bottom Next]

fun a_evalF_cases
 where "a_evalF_cases (PC (Lambda lab vs c, \<beta>)) as ve b = undefined"
     | "a_evalF_cases (PP (Plus cp)) [a1, a2, cnt] ve b = undefined"
     | "a_evalF_cases (PP (prim.If cp1 cp2)) [v,cntt,cntf] ve b = undefined"
     | "a_evalF_cases AStop [v] ve b = undefined"

lemmas a_fstate_case_x = a_evalF_cases.cases[
  OF case_split, of _ "\<lambda>_ vs _ _ as _ _ . length vs = length as",
  case_names "Closure" "Closure_inv" "Plus" "If" "Stop"]

lemmas a_cl_cases = prod.exhaust[OF lambda.exhaust, of _ "\<lambda> a _ . a"]
lemmas a_ds_cases = list.exhaust[
  OF _ list.exhaust,  of _ _ "\<lambda>_ x. x",
  OF _ _ list.exhaust  ,of _ _ "\<lambda>_ _ _ x. x" ,
  OF _ _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ _ x. x"
  ]
lemmas a_ds_cases_stop = list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"]
lemmas a_fstate_case = prod_cases4[OF proc.exhaust, of _ "\<lambda>x _ _ _ . x",
  OF a_cl_cases prim.exhaust, of _ "\<lambda> _ _ _ _ a . a" _ "\<lambda> _ _ _ _ a. a",
  OF case_split a_ds_cases a_ds_cases a_ds_cases_stop,
  of _ "\<lambda>_ as _ _ _ _ _ _ vs _ . length vs = length as" _ "\<lambda> _ ds _ _ _ _ . ds" "\<lambda> _ ds _ _ _ _ _. ds" "\<lambda> _ ds _ _. ds"]

text \<open>
Not surprisingly, the abstract semantics of a whole program is defined using \<open>\<aF>\<close> with suitably initialized arguments. The function \<open>the_elem\<close> extracts a value from a singleton set. This works because we know that \<open>\<aA>\<close> returns such a set when given a lambda expression.
\<close>

definition evalCPS_a :: "prog \<Rightarrow> ('c::contour) \<aans>" ("\<aPR>")
  where "\<aPR> l = (let ve = {}.;
                          \<beta> = Map.empty;
                          f = \<aA> (L l) \<beta> ve
                      in  \<aF>\<cdot>(Discr (the_elem f,[{AStop}],ve,\<abinit>)))"

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Functions\<close>
theory Functions_Base
  imports HOL.HOL
begin

definition "id x \<equiv> x"

lemma id_eq_self [simp]: "id x = x"
  unfolding id_def ..

definition "comp f g x \<equiv> f (g x)"

bundle comp_syntax begin notation comp (infixl "\<circ>" 55) end
bundle no_comp_syntax begin no_notation comp (infixl "\<circ>" 55) end
unbundle comp_syntax

lemma comp_eq [simp]: "(f \<circ> g) x = f (g x)"
  unfolding comp_def ..

lemma id_comp_eq [simp]: "id \<circ> f = f"
  by (rule ext) simp

lemma comp_id_eq [simp]: "f \<circ> id = f"
  by (rule ext) simp

definition "dep_fun_map f g h x \<equiv> g x (f x) (h (f x))"

abbreviation "fun_map f g h \<equiv> dep_fun_map f (\<lambda>_ _. g) h"

bundle dep_fun_map_syntax begin
syntax
  "_fun_map" :: "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow>
    ('a \<Rightarrow> 'd)" ("(_) \<rightarrow> (_)" [41, 40] 40)
  "_dep_fun_map" :: "idt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow>
    ('a \<Rightarrow> 'd)" ("[_/ : / _] \<rightarrow> (_)" [41, 41, 40] 40)
end
bundle no_dep_fun_map_syntax begin
no_syntax
  "_fun_map" :: "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow>
    ('a \<Rightarrow> 'd)" ("(_) \<rightarrow> (_)" [41, 40] 40)
  "_dep_fun_map" :: "idt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow>
    ('a \<Rightarrow> 'd)" ("[_/ : / _] \<rightarrow> (_)" [41, 41, 40] 40)
end
unbundle dep_fun_map_syntax
translations
  "f \<rightarrow> g" \<rightleftharpoons> "CONST fun_map f g"
  "[x : f] \<rightarrow> g" \<rightleftharpoons> "CONST dep_fun_map f (\<lambda>x. g)"

lemma dep_fun_map_eq [simp]: "([x : f] \<rightarrow> g x) h x = g x (f x) (h (f x))"
  unfolding dep_fun_map_def ..

lemma fun_map_eq_comp [simp]: "(f \<rightarrow> g) h = g \<circ> h \<circ> f"
  by fastforce

lemma fun_map_eq [simp]: "(f \<rightarrow> g) h x = g (h (f x))"
  unfolding fun_map_eq_comp by simp

lemma fun_map_id_eq_comp [simp]: "fun_map id = (\<circ>)"
  by (intro ext) simp

lemma fun_map_id_eq_comp' [simp]: "(f \<rightarrow> id) h = h \<circ> f"
  by (intro ext) simp

end


theory Free_Idempotent_Monoid imports
  "HOL-Library.Confluent_Quotient"
begin

inductive cancel1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where cancel1: "xs \<noteq> [] \<Longrightarrow> cancel1 (gs @ xs @ xs @ gs') (gs @ xs @ gs')"

abbreviation cancel where "cancel \<equiv> cancel1\<^sup>*\<^sup>*"

lemma cancel1_append_same1:
  assumes "cancel1 xs ys"
  shows "cancel1 (zs @ xs) (zs @ ys)"
using assms
proof cases
  case (cancel1 ys gs gs')
  from \<open>ys \<noteq> []\<close> have "cancel1 ((zs @ gs) @ ys @ ys @ gs') ((zs @ gs) @ ys @ gs')" ..
  with cancel1 show ?thesis by simp
qed

lemma cancel_append_same1: "cancel (zs @ xs) (zs @ ys)" if "cancel xs ys"
  using that by induction(blast intro: rtranclp.rtrancl_into_rtrancl cancel1_append_same1)+

lemma cancel1_append_same2: "cancel1 xs ys \<Longrightarrow> cancel1 (xs @ zs) (ys @ zs)"
by(cases rule: cancel1.cases)(auto intro: cancel1.intros)

lemma cancel_append_same2: "cancel (xs @ zs) (ys @ zs)" if "cancel xs ys"
  using that by induction(blast intro: rtranclp.rtrancl_into_rtrancl cancel1_append_same2)+

lemma cancel1_same:
  assumes "xs \<noteq> []"
  shows "cancel1 (xs @ xs) xs"
proof -
  have "cancel1 ([] @ xs @ xs @ []) ([] @ xs @ [])" using assms ..
  thus ?thesis by simp
qed

lemma cancel_same: "cancel (xs @ xs) xs"
  by(cases "xs = []")(auto intro: cancel1_same)

abbreviation (input) eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where "eq \<equiv> equivclp cancel1"

lemma eq_sym: "eq x y \<Longrightarrow> eq y x"
  by(rule equivclp_sym)

lemma equivp_eq: "equivp eq" by simp

lemma eq_append_same1: "eq xs' ys' \<Longrightarrow> eq (xs @ xs') (xs @ ys')"
  by(induction rule: equivclp_induct)(auto intro: cancel1_append_same1 equivclp_into_equivclp)

lemma append_eq_cong: "\<lbrakk>eq xs ys; eq xs' ys'\<rbrakk> \<Longrightarrow> eq (xs @ xs') (ys @ ys')"
  by(induction rule: equivclp_induct)(auto intro: eq_append_same1 equivclp_into_equivclp cancel1_append_same2)

quotient_type 'a fim = "'a list" / eq by simp

instantiation fim :: (type) monoid_add begin
lift_definition zero_fim :: "'a fim" is "[]" .
lift_definition plus_fim :: "'a fim \<Rightarrow> 'a fim \<Rightarrow> 'a fim" is "(@)" by(rule append_eq_cong)
instance by(intro_classes; transfer; simp)
end

lemma plus_idem_fim [simp]: fixes x :: "'a fim" shows "x + x = x"
proof transfer
  fix xs :: "'a list"
  show "eq (xs @ xs) xs"
  proof(cases "xs = []")
    case False thus ?thesis using cancel1_same[of xs] by(auto)
  qed simp
qed

inductive pcancel1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  pcancel1: "pcancel1 (concat xss) (concat yss)" if "list_all2 (\<lambda>xs ys. xs = ys \<or> xs = ys @ ys) xss yss"

lemma cancel1_into_pcancel1: "pcancel1 xs ys" if "cancel1 xs ys"
  using that
proof cases
  case (cancel1 xs gs gs')
  let ?xss = "[gs, xs @ xs, gs']" and ?yss = "[gs, xs, gs']"
  have "pcancel1 (concat ?xss) (concat ?yss)" by(rule pcancel1.intros) simp
  then show ?thesis using cancel1 by simp
qed

lemma pcancel_into_cancel: "cancel1\<^sup>*\<^sup>* xs ys" if "pcancel1 xs ys"
  using that
proof cases
  case (pcancel1 xss yss)
  from pcancel1(3) show ?thesis unfolding pcancel1(1-2)
    apply induction
     apply simp
    apply(auto intro: cancel_append_same1)
    apply(rule rtranclp_trans)
    apply(subst append_assoc[symmetric])
     apply(rule cancel_append_same2)
     apply(rule cancel_same)
    apply(auto intro: cancel_append_same1)
    done
qed

lemma pcancel1_cancel1_confluent:
  assumes "pcancel1 xs ys"
    and "cancel1 zs ys"
  shows "\<exists>us. cancel us xs \<and> pcancel1 us zs"
proof -
  let ?P = "\<lambda>xs ys. xs = ys \<or> xs = ys @ ys"
  consider ass as2 bs1 bss bs2 cs1 css ass' as2bs1 bss' bs2cs1 css'
    where "ys = concat ass @ as2 @ bs1 @ concat bss @ bs2 @ cs1 @ concat css"
     and "xs = concat ass' @ as2bs1 @ concat bss' @ bs2cs1 @ concat css'"
     and "zs = concat ass @ as2 @ bs1 @ concat bss @ bs2 @ bs1 @ concat bss @ bs2 @ cs1 @ concat css"
     and "list_all2 ?P ass' ass"
     and "list_all2 ?P bss' bss"
     and "list_all2 ?P css' css"
     and "?P as2bs1 (as2 @ bs1)"
     and "?P bs2cs1 (bs2 @ cs1)"
   | ass as2 bs cs1 css ass' css'
   where "ys = concat ass @ as2 @ bs @ cs1 @ concat css"
     and "xs = concat ass' @ as2 @ bs @ cs1 @ as2 @ bs @ cs1 @ concat css'"
     and "zs = concat ass @ as2 @ bs @ bs @ cs1 @ concat css"
     and "list_all2 ?P ass' ass"
     and "list_all2 ?P css' css"
  proof -
    from assms obtain xss bs as cs yss
      where xs: "xs = concat xss" and zs: "zs = as @ bs @ bs @ cs"
      and xss: "list_all2 (\<lambda>xs ys. xs = ys \<or> xs = ys @ ys) xss yss"
      and ys: "ys = as @ bs @ cs"
      and yss: "concat yss = as @ bs @ cs"
      and bs: "bs \<noteq> []"
      by(clarsimp simp add: pcancel1.simps cancel1.simps)
    from yss bs obtain ass as2 BS bcss
      where yss: "yss = ass @ (as2 @ BS) # bcss"
       and as: "as = concat ass @ as2"
       and eq: "bs @ cs = BS @ concat bcss"
      by(auto simp add: concat_eq_append_conv split: if_split_asm)
    define bcss' where "bcss' = (if bcss = [] then [[]] else bcss)"
    have bcss': "bcss' \<noteq> []" by(simp add: bcss'_def)
    from eq consider us where "bs = BS @ us" "concat bcss = us @ cs" "bcss \<noteq> []" |
      "BS = bs @ cs" "bcss = []" |
      us where "BS = bs @ us" "cs = us @ concat bcss"
      by(cases "bcss = []")(auto simp add: append_eq_append_conv2)
    then show thesis
    proof cases
      case 1
      from 1(2,3) obtain bss bs2 cs1 css
        where "bcss = bss @ (bs2 @ cs1) # css"
          and us: "us = concat bss @ bs2"
          and cs: "cs = cs1 @ concat css" by(auto simp add: concat_eq_append_conv)
      with 1 xs xss ys yss zs as that(1)[of ass as2 BS bss bs2 cs1 css] show ?thesis
        by(clarsimp simp add: list_all2_append2 list_all2_Cons2)
    next
      case 2
      with xs xss ys yss zs as show ?thesis
        using that(1)[of ass as2 bs "[]" "[]" "[]" "[cs]" _ "as2 @ bs" "[]" "[]" "[cs]"]
        using that(2)[of ass as2 bs cs "[]"]
        by(auto simp add: list_all2_append2 list_all2_Cons2)
    next
      case 3
      with xs xss ys yss zs as show ?thesis
        using that(1)[of ass as2 "[]" "[bs]" "[]" "us" "bcss" _ "as2" "[bs]"] that(2)[of ass as2 bs us bcss]
        by(auto simp add: list_all2_append2 list_all2_Cons2)
    qed
  qed
  then show ?thesis
  proof cases
    case 1
    let ?us = "concat ass' @ as2bs1 @ concat bss' @ bs2 @ bs1 @ concat bss' @ bs2cs1 @ concat css'"
    have "?us = concat (ass' @ [as2bs1] @ bss' @ [bs2 @ bs1] @ bss' @ [bs2cs1] @ css')" by simp
    also have "pcancel1 \<dots> (concat (ass @ [as2 @ bs1] @ bss @ [bs2 @ bs1] @ bss @ [bs2 @ cs1] @ css))"
      by(rule pcancel1.intros)(use 1 in \<open>simp add: list_all2_appendI\<close>)
    also have "\<dots> = zs" using 1 by simp
    also have "cancel ?us xs"
    proof -
      define as2b where "as2b = (if as2bs1 = as2 @ bs1 then as2 else as2 @ bs1 @ as2)"
      have as2bs1: "as2bs1 = as2b @ bs1" using 1 by(auto simp add: as2b_def)
      define b2cs where "b2cs = (if bs2cs1 = bs2 @ cs1 then cs1 else cs1 @ bs2 @ cs1)"
      have bs2cs1: "bs2cs1 = bs2 @ b2cs" using 1 by(auto simp add: b2cs_def)
      have "?us = (concat ass' @ as2b) @ ((bs1 @ concat bss' @ bs2) @ (bs1 @ concat bss' @ bs2)) @ b2cs @ concat css'"
        by(simp add: as2bs1 bs2cs1)
      also have "cancel \<dots> ((concat ass' @ as2b) @ (bs1 @ concat bss' @ bs2) @ b2cs @ concat css')"
        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
      also have "\<dots> = xs" using 1 bs2cs1 as2bs1 by simp
      finally show ?thesis .
    qed
    ultimately show ?thesis by blast
  next
    case 2
    let ?us = "concat ass' @ as2 @ bs @ bs @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css'"
    have "?us = concat (ass' @ [as2 @ bs @ bs @ cs1 @ as2 @ bs @ bs @ cs1] @ css')" by simp
    also have "pcancel1 \<dots> (concat (ass @ [as2 @ bs @ bs @ cs1] @ css))"
      by(intro pcancel1.intros list_all2_appendI)(simp_all add: 2)
    also have "\<dots> = zs" using 2 by simp
    also have "cancel ?us xs"
    proof -
      have "?us = (concat ass' @ as2) @ (bs @ bs) @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css'" by simp
      also have "cancel \<dots> ((concat ass' @ as2) @ bs @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css')"
        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
      also have "\<dots> = (concat ass' @ as2 @ bs @ cs1 @ as2) @ (bs @ bs) @ cs1 @ concat css'" by simp
      also have "cancel \<dots> ((concat ass' @ as2 @ bs @ cs1 @ as2) @ bs @ cs1 @ concat css')"
        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
      also have "\<dots> = xs" using 2 by simp
      finally show ?thesis .
    qed
    ultimately show ?thesis by blast
  qed
qed

lemma pcancel1_cancel_confluent:
  assumes "pcancel1 xs ys"
    and "cancel zs ys"
  shows "\<exists>us. cancel us xs \<and> pcancel1 us zs"
  using assms(2,1)
  by(induction arbitrary: xs)(fastforce elim!: rtranclp_trans dest: pcancel1_cancel1_confluent)+

lemma cancel1_semiconfluent:
  assumes "cancel1 xs ys"
    and "cancel zs ys"
  shows "\<exists>us. cancel us xs \<and> cancel us zs"
  using pcancel1_cancel_confluent[OF cancel1_into_pcancel1, OF assms]
  by(blast intro: pcancel_into_cancel)

lemma semiconfluentp_cancel1: "semiconfluentp cancel1\<inverse>\<inverse>"
  by(auto simp add: semiconfluentp_def rtranclp_conversep dest: cancel1_semiconfluent)

lemma retract_cancel1_aux:
  assumes "cancel1 ys (map f xs)"
  shows "\<exists>zs. cancel1 zs xs \<and> ys = map f zs \<and> set zs \<subseteq> set xs"
  using assms
  by cases(fastforce simp add: map_eq_append_conv append_eq_map_conv intro: cancel1.intros)

lemma retract_cancel1:
  assumes "cancel1 ys (map f xs)"
  shows "\<exists>zs. eq xs zs \<and> ys = map f zs \<and> set zs \<subseteq> set xs"
  using retract_cancel1_aux[OF assms] by(blast intro: symclpI)

lemma cancel1_set_eq:
  assumes "cancel1 ys xs"
  shows "set ys = set xs"
  using assms by cases auto

lemma eq_set_eq: "set xs = set ys" if "eq xs ys"
  using that by(induction)(auto dest!: cancel1_set_eq elim!: symclpE)

context includes lifting_syntax begin
lemma map_respect_cancel1: "((=) ===> cancel1 ===> eq) map map"
  by(auto 4 4 simp add: rel_fun_def cancel1.simps intro: symclpI cancel1.intros)

lemma map_respect_eq: "((=) ===> eq ===> eq) map map"
  apply(intro rel_funI; hypsubst)
  subgoal for _ f x y
    by(induction rule: equivclp_induct)
      (auto dest: map_respect_cancel1[THEN rel_funD, THEN rel_funD, OF refl] intro: eq_sym equivclp_trans)
  done
end

lemma confluent_quotient_fim:
  "confluent_quotient cancel1\<inverse>\<inverse> eq eq eq eq eq (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
  by(unfold_locales)(auto dest: retract_cancel1 eq_set_eq simp add: list.in_rel list.rel_compp map_respect_eq[THEN rel_funD, OF refl] semiconfluentp_imp_confluentp semiconfluentp_cancel1)+

lift_bnf 'a fim
  subgoal for A B by(rule confluent_quotient.subdistributivity[OF confluent_quotient_fim])
  subgoal by(force dest: eq_set_eq)
  done

end