(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Factoring Arbitrary Integer Polynomials\<close>

text \<open>We combine the factorization algorithm for square-free integer polynomials
  with a square-free factorization algorithm to
  a factorization algorithm for integer polynomials which does not make
  any assumptions.\<close>
theory Factorize_Int_Poly
imports
  Berlekamp_Zassenhaus
  Square_Free_Factorization_Int
begin

hide_const coeff monom
lifting_forget poly.lifting

typedef int_poly_factorization_algorithm = "{alg.
  \<forall> (f :: int poly) fs. square_free f \<longrightarrow> degree f > 0 \<longrightarrow> alg f = fs \<longrightarrow>
  (f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible\<^sub>d fi))}"
  by (rule exI[of _ berlekamp_zassenhaus_factorization],
      insert berlekamp_zassenhaus_factorization_irreducible\<^sub>d, auto)

setup_lifting type_definition_int_poly_factorization_algorithm

lift_definition int_poly_factorization_algorithm :: "int_poly_factorization_algorithm \<Rightarrow>
  (int poly \<Rightarrow> int poly list)" is "\<lambda> x. x" .

lemma int_poly_factorization_algorithm_irreducible\<^sub>d:
  assumes "int_poly_factorization_algorithm alg f = fs"
  and "square_free f"
  and "degree f > 0"
shows "f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible\<^sub>d fi)"
  using assms by (transfer, auto)

corollary int_poly_factorization_algorithm_irreducible:
  assumes res: "int_poly_factorization_algorithm alg f = fs"
  and sf: "square_free f"
  and deg: "degree f > 0"
  and pr: "primitive f"
  shows "f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible fi \<and> degree fi > 0 \<and> primitive fi)"
proof (intro conjI ballI)
  note * = int_poly_factorization_algorithm_irreducible\<^sub>d[OF res sf deg]
  from * show f: "f = prod_list fs" by auto
  fix fi assume fi: "fi \<in> set fs"
  with primitive_prod_list[OF pr[unfolded f]] show "primitive fi" by auto
  from irreducible_primitive_connect[OF this] * pr[unfolded f] fi
  show "irreducible fi" by auto
  from * fi show "degree fi > 0" by (auto)
qed

lemma irreducible_imp_square_free:
  assumes irr: "irreducible (p::'a::idom poly)" shows "square_free p"
proof(intro square_freeI)
  from irr show p0: "p \<noteq> 0" by auto
  fix a assume "a * a dvd p"
  then obtain b where paab: "p = a * (a * b)" by (elim dvdE, auto)
  assume "degree a > 0"
  then have a1: "\<not> a dvd 1" by (auto simp: poly_dvd_1)
  then have ab1: "\<not> a * b dvd 1" using dvd_mult_left by auto
  from paab irr a1 ab1 show False by force
qed

(* TODO: Move *)
lemma not_mem_set_dropWhileD: "x \<notin> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs \<Longrightarrow> P x"
  by (metis dropWhile_append3 in_set_conv_decomp)

lemma primitive_reflect_poly:
  fixes f :: "'a :: comm_semiring_1 poly"
  shows "primitive (reflect_poly f) = primitive f"
proof-
  have "(\<forall> a \<in> set (coeffs f). x dvd a) \<longleftrightarrow> (\<forall>a \<in> set (dropWhile ((=) 0) (coeffs f)). x dvd a)" for x
    by (auto dest: not_mem_set_dropWhileD set_dropWhileD)
  then show ?thesis by (auto simp: primitive_def coeffs_reflect_poly)
qed

(* TODO: move *)
lemma gcd_list_sub:
  assumes "set xs \<subseteq> set ys" shows "gcd_list ys dvd gcd_list xs"
  by (metis Gcd_fin.subset assms semiring_gcd_class.gcd_dvd1)

lemma content_reflect_poly:
  "content (reflect_poly f) = content f" (is "?l = ?r")
proof-
  have l: "?l = gcd_list (dropWhile ((=) 0) (coeffs f))" (is "_ = gcd_list ?xs")
    by (simp add: content_def reflect_poly_def)
  have "set ?xs \<subseteq> set (coeffs f)" by (auto dest: set_dropWhileD)
  from gcd_list_sub[OF this]
  have "?r dvd gcd_list ?xs" by (simp add: content_def)
  with l have rl: "?r dvd ?l" by auto
  have "set (coeffs f) \<subseteq> set (0 # ?xs)" by (auto dest: not_mem_set_dropWhileD)
  from gcd_list_sub[OF this]
  have "gcd_list ?xs dvd ?r" by (simp add: content_def)
  with l have lr: "?l dvd ?r" by auto
  from rl lr show "?l = ?r" by (simp add: associated_eqI)
qed

lemma coeff_primitive_part: "content f * coeff (primitive_part f) i = coeff f i"
  using arg_cong[OF content_times_primitive_part[of f], of "\<lambda>f. coeff f _", unfolded coeff_smult].

(* TODO: move *)
lemma smult_cancel[simp]:
  fixes c :: "'a :: idom"
  shows "smult c f = smult c g \<longleftrightarrow> c = 0 \<or> f = g"
proof-
  have l: "smult c f = [:c:] * f" by simp
  have r: "smult c g = [:c:] * g" by simp
  show ?thesis unfolding l r mult_cancel_left by simp
qed

lemma primitive_part_reflect_poly:
  fixes f :: "'a :: {semiring_gcd,idom} poly"
  shows "primitive_part (reflect_poly f) = reflect_poly (primitive_part f)" (is "?l = ?r")
  using content_times_primitive_part[of "reflect_poly f"]
proof-
  note content_reflect_poly[of f, symmetric]
  also have "smult (content (reflect_poly f)) ?l = reflect_poly f" by simp
  also have "... = reflect_poly (smult (content f) (primitive_part f))" by simp
  finally show ?thesis unfolding reflect_poly_smult smult_cancel by auto
qed

(* TODO: move *)
lemma reflect_poly_eq_zero[simp]:
  "reflect_poly f = 0 \<longleftrightarrow> f = 0"
proof
  assume "reflect_poly f = 0"
  then have "coeff (reflect_poly f) 0 = 0" by simp
  then have "lead_coeff f = 0" by simp
  then show "f = 0" by simp
qed simp

lemma irreducible\<^sub>d_reflect_poly_main:
  fixes f :: "'a :: {idom, semiring_gcd} poly"
  assumes nz: "coeff f 0 \<noteq> 0"
    and irr: "irreducible\<^sub>d (reflect_poly f)"
  shows "irreducible\<^sub>d f"
proof
  let ?r = reflect_poly
  from irr degree_reflect_poly_eq[OF nz] show "degree f > 0" by auto
  fix g h
  assume deg: "degree g < degree f" "degree h < degree f" and fgh: "f = g * h"
  from arg_cong[OF fgh, of "\<lambda> f. coeff f 0"] nz
  have nz': "coeff g 0 \<noteq> 0" by (auto simp: coeff_mult_0)
  note rfgh = arg_cong[OF fgh, of reflect_poly, unfolded reflect_poly_mult[of g h]]
  from deg degree_reflect_poly_le[of g] degree_reflect_poly_le[of h] degree_reflect_poly_eq[OF nz]
  have "degree (?r h) < degree (?r f)" "degree (?r g) < degree (?r f)" by auto
  with irr rfgh show False by auto
qed

lemma irreducible\<^sub>d_reflect_poly:
  fixes f :: "'a :: {idom, semiring_gcd} poly"
  assumes nz: "coeff f 0 \<noteq> 0"
  shows "irreducible\<^sub>d (reflect_poly f) = irreducible\<^sub>d f"
proof
  assume "irreducible\<^sub>d (reflect_poly f)"
  from irreducible\<^sub>d_reflect_poly_main[OF nz this] show "irreducible\<^sub>d f" .
next
  from nz have nzr: "coeff (reflect_poly f) 0 \<noteq> 0" by auto
  assume "irreducible\<^sub>d f"
  with nz have "irreducible\<^sub>d (reflect_poly (reflect_poly f))" by simp
  from irreducible\<^sub>d_reflect_poly_main[OF nzr this]
  show "irreducible\<^sub>d (reflect_poly f)" .
qed

lemma irreducible_reflect_poly:
  fixes f :: "'a :: {idom,semiring_gcd} poly"
  assumes nz: "coeff f 0 \<noteq> 0"
  shows "irreducible (reflect_poly f) = irreducible f" (is "?l = ?r")
proof (cases "degree f = 0")
  case True then obtain f0 where "f = [:f0:]" by (auto dest: degree0_coeffs)
  then show ?thesis by simp
next
  case deg: False
  show ?thesis
  proof (cases "primitive f")
    case False
    with deg irreducible_imp_primitive[of f] irreducible_imp_primitive[of "reflect_poly f"] nz
    show ?thesis unfolding primitive_reflect_poly by auto
  next
    case cf: True
    let ?r = "reflect_poly"
    from nz have nz': "coeff (?r f) 0 \<noteq> 0" by auto
    let ?ir = irreducible\<^sub>d
    from irreducible\<^sub>d_reflect_poly[OF nz] irreducible\<^sub>d_reflect_poly[OF nz'] nz
    have "?ir f \<longleftrightarrow> ?ir (reflect_poly f)" by auto
    also have "... \<longleftrightarrow> irreducible (reflect_poly f)"
      by (rule irreducible_primitive_connect, unfold primitive_reflect_poly, fact cf)
    finally show ?thesis
      by (unfold irreducible_primitive_connect[OF cf], auto)
  qed
qed

(* TODO: Move *)
lemma reflect_poly_dvd: "(f :: 'a :: idom poly) dvd g \<Longrightarrow> reflect_poly f dvd reflect_poly g"
  unfolding dvd_def by (auto simp: reflect_poly_mult)

lemma square_free_reflect_poly: fixes f :: "'a :: idom poly"
  assumes sf: "square_free f"
  and nz: "coeff f 0 \<noteq> 0"
shows "square_free (reflect_poly f)" unfolding square_free_def
proof (intro allI conjI impI notI)
  let ?r = reflect_poly
  from sf[unfolded square_free_def]
  have f0: "f \<noteq> 0" and sf: "\<And> q. 0 < degree q \<Longrightarrow> q * q dvd f \<Longrightarrow> False" by auto
  from f0 nz show "?r f = 0 \<Longrightarrow> False" by auto
  fix q
  assume 0: "0 < degree q" and dvd: "q * q dvd ?r f"
  from dvd have "q dvd ?r f" by auto
  then obtain x where id: "?r f = q * x" by fastforce
  {
    assume "coeff q 0 = 0"
    hence "coeff (?r f) 0 = 0" using id by (auto simp: coeff_mult)
    with nz have False by auto
  }
  hence nzq: "coeff q 0 \<noteq> 0" by auto
  from dvd have "?r (q * q) dvd ?r (?r f)" by (rule reflect_poly_dvd)
  also have "?r (?r f) = f" using nz by auto
  also have "?r (q * q) = ?r q * ?r q" by (rule reflect_poly_mult)
  finally have "?r q * ?r q dvd f" .
  from sf[OF _ this] 0 nzq show False by simp
qed

lemma gcd_reflect_poly: fixes f :: "'a :: {factorial_ring_gcd, semiring_gcd_mult_normalize} poly"
  assumes nz: "coeff f 0 \<noteq> 0" "coeff g 0 \<noteq> 0"
  shows "gcd (reflect_poly f) (reflect_poly g) = normalize (reflect_poly (gcd f g))"
proof (rule sym, rule gcdI)
  have "gcd f g dvd f" by auto
  from reflect_poly_dvd[OF this]
  show "normalize (reflect_poly (gcd f g)) dvd reflect_poly f" by simp
  have "gcd f g dvd g" by auto
  from reflect_poly_dvd[OF this]
  show "normalize (reflect_poly (gcd f g)) dvd reflect_poly g" by simp
  show "normalize (normalize (reflect_poly (gcd f g))) = normalize (reflect_poly (gcd f g))" by auto
  fix h
  assume hf: "h dvd reflect_poly f" and hg: "h dvd reflect_poly g"
  from hf obtain k where "reflect_poly f = h * k" unfolding dvd_def by auto
  from arg_cong[OF this, of "\<lambda> f. coeff f 0", unfolded coeff_mult_0] nz(1) have h: "coeff h 0 \<noteq> 0" by auto
  from reflect_poly_dvd[OF hf] reflect_poly_dvd[OF hg]
  have "reflect_poly h dvd f" "reflect_poly h dvd g" using nz by auto
  hence "reflect_poly h dvd gcd f g" by auto
  from reflect_poly_dvd[OF this] h have "h dvd reflect_poly (gcd f g)" by auto
  thus "h dvd normalize (reflect_poly (gcd f g))" by auto
qed

lemma linear_primitive_irreducible:
  fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  assumes deg: "degree f = 1" and cf: "primitive f"
  shows "irreducible f"
proof (intro irreducibleI)
  fix a b assume fab: "f = a * b"
  with deg have a0: "a \<noteq> 0" and b0: "b \<noteq> 0" by auto
  from deg[unfolded fab] degree_mult_eq[OF this] have "degree a = 0 \<or> degree b = 0" by auto
  then show "a dvd 1 \<or> b dvd 1"
  proof
    assume "degree a = 0"
    then obtain a0 where a: "a = [:a0:]" by (auto dest:degree0_coeffs)
    with fab have "c \<in> set (coeffs f) \<Longrightarrow> a0 dvd c" for c by (cases "a0 = 0", auto simp: coeffs_smult)
    with cf show ?thesis by (auto dest: primitiveD simp: a)
  next
    assume "degree b = 0"
    then obtain b0 where b: "b = [:b0:]" by (auto dest:degree0_coeffs)
    with fab have "c \<in> set (coeffs f) \<Longrightarrow> b0 dvd c" for c by (cases "b0 = 0", auto simp: coeffs_smult)
    with cf show ?thesis by (auto dest: primitiveD simp: b)
  qed
qed (insert deg, auto simp: poly_dvd_1)

lemma square_free_factorization_last_coeff_nz:
  assumes sff: "square_free_factorization f (a, fs)"
  and mem: "(fi,i) \<in> set fs"
  and nz: "coeff f 0 \<noteq> 0"
shows "coeff fi 0 \<noteq> 0"
proof
  assume fi: "coeff fi 0 = 0"
  note sff_list = square_free_factorization_prod_list[OF sff]
  note sff = square_free_factorizationD[OF sff]
  from sff_list have "coeff f 0 = a * coeff (\<Prod>(a, i)\<leftarrow>fs. a ^ Suc i) 0" by simp
  with split_list[OF mem] fi have "coeff f 0 = 0"
    by (auto simp: coeff_mult)
  with nz show False by simp
qed

context
  fixes alg :: int_poly_factorization_algorithm
begin
(* main factorization algorithm for square-free, content-free, non-constant polynomial
   that do not have 0 as root, with special cases and reciprocal polynomials *)
definition main_int_poly_factorization :: "int poly \<Rightarrow> int poly list" where
  "main_int_poly_factorization f = (let df = degree f
    in if df = 1 then [f] else
    if abs (coeff f 0) < abs (coeff f df) \<comment> \<open>take reciprocal polynomial, if \<open>f(0) < lc(f)\<close>\<close>
     then map reflect_poly (int_poly_factorization_algorithm alg (reflect_poly f))
     else int_poly_factorization_algorithm alg f)"

(* preprocessing via square-free factorization *)
definition internal_int_poly_factorization :: "int poly \<Rightarrow> int \<times> (int poly \<times> nat) list" where
  "internal_int_poly_factorization f = (
    case square_free_factorization_int f of
     (a,gis) \<Rightarrow> (a, [ (h,i) . (g,i) \<leftarrow> gis, h \<leftarrow> main_int_poly_factorization g ])
  )"

lemma internal_int_poly_factorization_code[code]: "internal_int_poly_factorization f = (
    case square_free_factorization_int f of (a,gis) \<Rightarrow>
   (a, concat (map (\<lambda> (g,i). (map (\<lambda> f. (f,i)) (main_int_poly_factorization g))) gis)))"
  unfolding internal_int_poly_factorization_def by auto

(* factorization for polynomials that do not have 0 as root,
   with special treatment of polynomials of degree at most 1 *)
definition factorize_int_last_nz_poly :: "int poly \<Rightarrow> int \<times> (int poly \<times> nat) list" where
  "factorize_int_last_nz_poly f = (let df = degree f
    in if df = 0 then (coeff f 0, []) else if df = 1 then (content f,[(primitive_part f,0)]) else
    internal_int_poly_factorization f)"

(* factorization for arbitrary polynomials *)
definition factorize_int_poly_generic :: "int poly \<Rightarrow> int \<times> (int poly \<times> nat) list" where
  "factorize_int_poly_generic f = (case x_split f of (n,g) \<comment> \<open>extract \<open>x^n\<close>\<close>
    \<Rightarrow> if g = 0 then (0,[]) else case factorize_int_last_nz_poly g of (a,fs)
    \<Rightarrow> if n = 0 then (a,fs) else (a, (monom 1 1, n - 1) # fs))"

lemma factorize_int_poly_0[simp]: "factorize_int_poly_generic 0 = (0,[])"
  unfolding factorize_int_poly_generic_def x_split_def by simp

lemma main_int_poly_factorization:
  assumes res: "main_int_poly_factorization f = fs"
  and sf: "square_free f"
  and df: "degree f > 0"
  and nz: "coeff f 0 \<noteq> 0"
shows "f = prod_list fs \<and> (\<forall> fi \<in> set fs. irreducible\<^sub>d fi)"
proof (cases "degree f = 1")
  case True
  with res[unfolded main_int_poly_factorization_def Let_def]
  have "fs = [f]" by auto
  with True show ?thesis by auto
next
  case False
  hence *: "(if degree f = 1 then t :: int poly list else e) = e" for t e by auto
  note res = res[unfolded main_int_poly_factorization_def Let_def *]
  show ?thesis
  proof (cases "abs (coeff f 0) < abs (coeff f (degree f))")
    case False
    with res have "int_poly_factorization_algorithm alg f = fs" by auto
    from int_poly_factorization_algorithm_irreducible\<^sub>d[OF this sf df] show ?thesis .
  next
    case True
    let ?f = "reflect_poly f"
    from square_free_reflect_poly[OF sf nz] have sf: "square_free ?f" .
    from nz df have df: "degree ?f > 0" by simp
    from True res obtain gs where fs: "fs = map reflect_poly gs"
      and gs: "int_poly_factorization_algorithm alg (reflect_poly f) = gs"
      by auto
    from int_poly_factorization_algorithm_irreducible\<^sub>d[OF gs sf df]
    have id: "reflect_poly ?f = reflect_poly (prod_list gs)" "?f = prod_list gs"
      and irr: "\<And> gi. gi \<in> set gs \<Longrightarrow> irreducible\<^sub>d gi" by auto
    from id(1) have f_fs: "f = prod_list fs" unfolding fs using nz
      by (simp add: reflect_poly_prod_list)
    {
      fix fi
      assume "fi \<in> set fs"
      from this[unfolded fs] obtain gi where gi: "gi \<in> set gs" and fi: "fi = reflect_poly gi" by auto
      {
        assume "coeff gi 0 = 0"
        with id(2) split_list[OF gi] have "coeff ?f 0 = 0"
          by (auto simp: coeff_mult)
        with nz have False by auto
      }
      hence nzg: "coeff gi 0 \<noteq> 0" by auto
      from irreducible\<^sub>d_reflect_poly[OF nzg] irr[OF gi] have "irreducible\<^sub>d fi" unfolding fi by simp
    }
    with f_fs show ?thesis by auto
  qed
qed

lemma internal_int_poly_factorization_mem:
  assumes f: "coeff f 0 \<noteq> 0"
  and res: "internal_int_poly_factorization f = (c,fs)"
  and mem: "(fi,i) \<in> set fs"
  shows "irreducible fi" "irreducible\<^sub>d fi" and "primitive fi" and "degree fi \<noteq> 0"
proof -
  obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
    by force
  from square_free_factorization_int[OF this]
  have sff: "square_free_factorization f (a, psi)"
    and cnt: "\<And> fi i. (fi, i) \<in> set psi \<Longrightarrow> primitive fi" by blast+
  from square_free_factorization_last_coeff_nz[OF sff _ f]
  have nz_fi: "\<And> fi i. (fi, i) \<in> set psi \<Longrightarrow> coeff fi 0 \<noteq> 0" by auto
  note res = res[unfolded internal_int_poly_factorization_def a_psi Let_def split]
  obtain fact where fact: "fact = (\<lambda> (q,i :: nat). (map (\<lambda> f. (f,i)) (main_int_poly_factorization q)))" by auto
  from res[unfolded split Let_def]
  have c: "c = a" and fs: "fs = concat (map fact psi)"
    unfolding fact by auto
  note sff' = square_free_factorizationD[OF sff]
  from mem[unfolded fs, simplified] obtain d j where psi: "(d,j) \<in> set psi"
     and fi: "(fi, i) \<in> set (fact (d,j))" by auto
  obtain hs where d: "main_int_poly_factorization d = hs" by force
  from fi[unfolded d split fact] have fi: "fi \<in> set hs" by auto
  from main_int_poly_factorization[OF d _ _ nz_fi[OF psi]] sff'(2)[OF psi] cnt[OF psi]
  have main: "d = prod_list hs" "\<And> fi. fi \<in> set hs \<Longrightarrow> irreducible\<^sub>d fi" by auto
  from main split_list[OF fi] have "content fi dvd content d" by auto
  with cnt[OF psi] show cnt: "primitive fi" by simp
  from main(2)[OF fi] show irr: "irreducible\<^sub>d fi" .
  show "irreducible fi"
    using irreducible_primitive_connect[OF cnt] irr by blast
  from irr show "degree fi \<noteq> 0" by auto
qed

lemma internal_int_poly_factorization:
  assumes f: "coeff f 0 \<noteq> 0"
  and res: "internal_int_poly_factorization f = (c,fs)"
  shows "square_free_factorization f (c,fs)"
proof -
  obtain a psi where a_psi: "square_free_factorization_int f = (a, psi)"
    by force
  from square_free_factorization_int[OF this]
  have sff: "square_free_factorization f (a, psi)"
    and pr: "\<And> fi i. (fi, i) \<in> set psi \<Longrightarrow> primitive fi" by blast+
  obtain fact where fact: "fact = (\<lambda> (q,i :: nat). (map (\<lambda> f. (f,i)) (main_int_poly_factorization q)))" by auto
  from res[unfolded split Let_def]
  have c: "c = a" and fs: "fs = concat (map fact psi)"
    unfolding fact internal_int_poly_factorization_def a_psi by auto
  note sff' = square_free_factorizationD[OF sff]
  show ?thesis unfolding square_free_factorization_def split
  proof (intro conjI impI allI)
    show "f = 0 \<Longrightarrow> c = 0" "f = 0 \<Longrightarrow> fs = []" using sff'(4) unfolding c fs by auto
    {
      fix a i
      assume "(a,i) \<in> set fs"
      from irreducible_imp_square_free internal_int_poly_factorization_mem[OF f res this]
      show "square_free a" "degree a > 0" by auto
    }
    from square_free_factorization_last_coeff_nz[OF sff _ f]
    have nz: "\<And> fi i. (fi, i) \<in> set psi \<Longrightarrow> coeff fi 0 \<noteq> 0" by auto
    have eq: "f = smult c (\<Prod>(a, i)\<leftarrow>fs. a ^ Suc i)" unfolding
      prod.distinct_set_conv_list[OF sff'(5)]
      sff'(1) c
    proof (rule arg_cong[where f = "smult a"], unfold fs, insert sff'(2) nz, induct psi)
      case (Cons pi psi)
      obtain p i where pi: "pi = (p,i)" by force
      obtain gs where gs: "main_int_poly_factorization p = gs" by auto
      from Cons(2)[of p i] have p: "square_free p" "degree p > 0" unfolding pi by auto
      from Cons(3)[of p i] have nz: "coeff p 0 \<noteq> 0" unfolding pi by auto
      from main_int_poly_factorization[OF gs p nz] have pgs: "p = prod_list gs" by auto
      have fact: "fact (p,i) = map (\<lambda> g. (g,i)) gs" unfolding fact split gs by auto
      have cong: "\<And> x y X Y. x = X \<Longrightarrow> y = Y \<Longrightarrow> x * y = X * Y" by auto
      show ?case unfolding pi list.simps prod_list.Cons split fact concat.simps prod_list.append
        map_append
      proof (rule cong)
        show "p ^ Suc i = (\<Prod>(a, i)\<leftarrow>map (\<lambda>g. (g, i)) gs. a ^ Suc i)" unfolding pgs
          by (induct gs, auto simp: ac_simps power_mult_distrib)
        show "(\<Prod>(a, i)\<leftarrow>psi. a ^ Suc i) = (\<Prod>(a, i)\<leftarrow>concat (map fact psi). a ^ Suc i)"
          by (rule Cons(1), insert Cons(2-3), auto)
      qed
    qed simp
    {
      fix i j l fi
      assume *: "j < length psi" "l < length (fact (psi ! j))" "fact (psi ! j) ! l = (fi, i)"
      from * have psi: "psi ! j \<in> set psi" by auto
      obtain d k where dk: "psi ! j = (d,k)" by force
      with * have psij: "psi ! j = (d,i)" unfolding fact split by auto
      from sff'(2)[OF psi[unfolded psij]] have d: "square_free d" "degree d > 0" by auto
      from nz[OF psi[unfolded psij]] have d0: "coeff d 0 \<noteq> 0" .
      from * psij fact
      have bz: "main_int_poly_factorization d = map fst (fact (psi ! j))" by (auto simp: o_def)
      from main_int_poly_factorization[OF bz d d0] pr[OF psi[unfolded dk]]
      have dhs: "d = prod_list (map fst (fact (psi ! j)))" by auto
      from * have mem: "fi \<in> set (map fst (fact (psi ! j)))"
        by (metis fst_conv image_eqI nth_mem set_map)
      from mem dhs psij d have "\<exists> d. fi \<in> set (map fst (fact (psi ! j))) \<and>
        d = prod_list (map fst (fact (psi ! j))) \<and>
        psi ! j = (d, i) \<and>
        square_free d" by blast
    } note deconstruct = this
    {
      fix k K fi i Fi I
      assume k: "k < length fs" "K < length fs" and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)"
      and diff: "k \<noteq> K"
      from nth_concat_diff[OF k[unfolded fs] diff, folded fs, unfolded length_map]
        obtain j l J L where diff: "(j, l) \<noteq> (J, L)"
          and j: "j < length psi" "J < length psi"
          and l: "l < length (map fact psi ! j)" "L < length (map fact psi ! J)"
          and fs: "fs ! k = map fact psi ! j ! l" "fs ! K = map fact psi ! J ! L" by blast+
      hence psij: "psi ! j \<in> set psi" by auto
      from j have id: "map fact psi ! j = fact (psi ! j)" "map fact psi ! J = fact (psi ! J)" by auto
      note l = l[unfolded id] note fs = fs[unfolded id]
      from j have psi: "psi ! j \<in> set psi" "psi ! J \<in> set psi" by auto
      from deconstruct[OF j(1) l(1) fs(1)[unfolded f, symmetric]]
      obtain d where mem: "fi \<in> set (map fst (fact (psi ! j)))"
        and d: "d = prod_list (map fst (fact (psi ! j)))" "psi ! j = (d, i)" "square_free d" by blast
      from deconstruct[OF j(2) l(2) fs(2)[unfolded f, symmetric]]
      obtain D where Mem: "Fi \<in> set (map fst (fact (psi ! J)))"
        and D: "D = prod_list (map fst (fact (psi ! J)))" "psi ! J = (D, I)" "square_free D" by blast
      from pr[OF psij[unfolded d(2)]] have cnt: "primitive d" .
      have "coprime fi Fi"
      proof (cases "J = j")
        case False
        from sff'(5) False j have "(d,i) \<noteq> (D,I)"
          unfolding distinct_conv_nth d(2)[symmetric] D(2)[symmetric] by auto
        from sff'(3)[OF psi[unfolded d(2) D(2)] this]
        have cop: "coprime d D" by auto
        from prod_list_dvd[OF mem, folded d(1)] have fid: "fi dvd d" by auto
        from prod_list_dvd[OF Mem, folded D(1)] have FiD: "Fi dvd D" by auto
        from coprime_divisors[OF fid FiD] cop show ?thesis by simp
      next
        case True note id = this
        from id diff have diff: "l \<noteq> L" by auto
        obtain bz where bz: "bz = map fst (fact (psi ! j))" by auto
        from fs[unfolded f] l
        have fi: "fi = bz ! l" "Fi = bz ! L"
          unfolding id bz by (metis fst_conv nth_map)+
        from d[folded bz] have sf: "square_free (prod_list bz)" by auto
        from d[folded bz] cnt have cnt: "content (prod_list bz) = 1" by auto
        from l have l: "l < length bz" "L < length bz" unfolding bz id by auto
        from l fi have "fi \<in> set bz" by auto
        from content_dvd_1[OF cnt prod_list_dvd[OF this]] have cnt: "content fi = 1" .
        obtain g where g: "g = gcd fi Fi" by auto
        have g': "g dvd fi" "g dvd Fi" unfolding g by auto
        define bef where "bef = take l bz"
        define aft where "aft = drop (Suc l) bz"
        from id_take_nth_drop[OF l(1)] l have bz: "bz = bef @ fi # aft" and bef: "length bef = l"
          unfolding bef_def aft_def fi by auto
        with l diff have mem: "Fi \<in> set (bef @ aft)" unfolding fi(2) by (auto simp: nth_append)
        from split_list[OF this] obtain Bef Aft where ba: "bef @ aft = Bef @ Fi # Aft" by auto
        have "prod_list bz = fi * prod_list (bef @ aft)" unfolding bz by simp
        also have "prod_list (bef @ aft) = Fi * prod_list (Bef @ Aft)" unfolding ba by auto
        finally have "fi * Fi dvd prod_list bz" by auto
        with g' have "g * g dvd prod_list bz" by (meson dvd_trans mult_dvd_mono)
        with sf[unfolded square_free_def] have deg: "degree g = 0" by auto
        from content_dvd_1[OF cnt g'(1)] have cnt: "content g = 1" .
        from degree0_coeffs[OF deg] obtain c where gc: "g = [: c :]" by auto
        from cnt[unfolded gc content_def, simplified] have "abs c = 1"
          by (cases "c = 0", auto)
        with g gc have "gcd fi Fi \<in> {1,-1}" by fastforce
        thus "coprime fi Fi"
          by (auto intro!: gcd_eq_1_imp_coprime)
            (metis dvd_minus_iff dvd_refl is_unit_gcd_iff one_neq_neg_one)
      qed
    } note cop = this
    show dist: "distinct fs" unfolding distinct_conv_nth
    proof (intro impI allI)
      fix k K
      assume k: "k < length fs" "K < length fs" and diff: "k \<noteq> K"
      obtain fi i Fi I where f: "fs ! k = (fi,i)" "fs ! K = (Fi,I)" by force+
      from cop[OF k f diff] have cop: "coprime fi Fi" .
      from k(1) f(1) have "(fi,i) \<in> set fs" unfolding set_conv_nth by force
      from internal_int_poly_factorization_mem[OF assms(1) res this] have "degree fi > 0" by auto
      hence "\<not> is_unit fi" by (simp add: poly_dvd_1)
      with cop coprime_id_is_unit[of fi] have "fi \<noteq> Fi" by auto
      thus "fs ! k \<noteq> fs ! K" unfolding f by auto
    qed
    show "f = smult c (\<Prod>(a, i)\<in>set fs. a ^ Suc i)" unfolding eq
      prod.distinct_set_conv_list[OF dist] by simp
    fix fi i Fi I
    assume mem: "(fi, i) \<in> set fs" "(Fi,I) \<in> set fs" and diff: "(fi, i) \<noteq> (Fi, I)"
    then obtain k K where k: "k < length fs" "K < length fs"
      and f: "fs ! k = (fi, i)" "fs ! K = (Fi, I)" unfolding set_conv_nth by auto
    with diff have diff: "k \<noteq> K" by auto
    from cop[OF k f diff] show "Rings.coprime fi Fi" by auto
  qed
qed

lemma factorize_int_last_nz_poly: assumes res: "factorize_int_last_nz_poly f = (c,fs)"
    and nz: "coeff f 0 \<noteq> 0"
shows "square_free_factorization f (c,fs)"
  "(fi,i) \<in> set fs \<Longrightarrow> irreducible fi"
  "(fi,i) \<in> set fs \<Longrightarrow> degree fi \<noteq> 0"
proof (atomize(full))
  from nz have lz: "lead_coeff f \<noteq> 0" by auto
  note res = res[unfolded factorize_int_last_nz_poly_def Let_def]
  consider (0) "degree f = 0"
    | (1) "degree f = 1"
    | (2) "degree f > 1" by linarith
  then show "square_free_factorization f (c,fs) \<and> ((fi,i) \<in> set fs \<longrightarrow> irreducible fi) \<and> ((fi,i) \<in> set fs \<longrightarrow> degree fi \<noteq> 0)"
  proof cases
    case 0
    from degree0_coeffs[OF 0] obtain a where f: "f = [:a:]" by auto
    from res show ?thesis unfolding square_free_factorization_def f by auto
  next
    case 1
    then have irr: "irreducible (primitive_part f)"
      by (auto intro!: linear_primitive_irreducible content_primitive_part)
    from irreducible_imp_square_free[OF irr] have sf: "square_free (primitive_part f)" .
    from 1 have f0: "f \<noteq> 0" by auto
    from res irr sf f0 show ?thesis unfolding square_free_factorization_def by (auto simp: 1)
  next
    case 2
    with res have "internal_int_poly_factorization f = (c,fs)" by auto
    from internal_int_poly_factorization[OF nz this] internal_int_poly_factorization_mem[OF nz this]
    show ?thesis by auto
  qed
qed

lemma factorize_int_poly: assumes res: "factorize_int_poly_generic f = (c,fs)"
shows "square_free_factorization f (c,fs)"
  "(fi,i) \<in> set fs \<Longrightarrow> irreducible fi"
  "(fi,i) \<in> set fs \<Longrightarrow> degree fi \<noteq> 0"
proof (atomize(full))
  obtain n g where xs: "x_split f = (n,g)" by force
  obtain d hs where fact: "factorize_int_last_nz_poly g = (d,hs)" by force
  from res[unfolded factorize_int_poly_generic_def xs split fact]
  have res: "(if g = 0 then (0, []) else if n = 0 then (d, hs) else (d, (monom 1 1, n - 1) # hs)) = (c, fs)" .
  note xs = x_split[OF xs]
  show "square_free_factorization f (c,fs) \<and> ((fi,i) \<in> set fs \<longrightarrow> irreducible fi) \<and> ((fi,i) \<in> set fs \<longrightarrow> degree fi \<noteq> 0)"
  proof (cases "g = 0")
    case True
    hence "f = 0" "c = 0" "fs = []" using res xs by auto
    thus ?thesis unfolding square_free_factorization_def by auto
  next
    case False
    with xs have "\<not> monom 1 1 dvd g" by auto
    hence "coeff g 0 \<noteq> 0" by (simp add: monom_1_dvd_iff')
    note fact = factorize_int_last_nz_poly[OF fact this]
    let ?x = "monom 1 1 :: int poly"
    have x: "content ?x = 1 \<and> lead_coeff ?x = 1 \<and> degree ?x = 1"
      by (auto simp add: degree_monom_eq monom_Suc content_def)
    from res False have res: "(if n = 0 then (d, hs) else (d, (?x, n - 1) # hs)) = (c, fs)" by auto
    show ?thesis
    proof (cases n)
      case 0
      with res xs have id: "fs = hs" "c = d" "f = g" by auto
      from fact show ?thesis unfolding id by auto
    next
      case (Suc m)
      with res have id: "c = d" "fs = (?x,m) # hs" by auto
      from Suc xs have fg: "f = monom 1 (Suc m) * g" and dvd: "\<not> ?x dvd g" by auto
      from x linear_primitive_irreducible[of ?x] have irr: "irreducible ?x" by auto
      from irreducible_imp_square_free[OF this] have sfx: "square_free ?x" .
      from irr fact have one: "(fi, i) \<in> set fs \<longrightarrow> irreducible fi \<and> degree fi \<noteq> 0" unfolding id by (auto simp: degree_monom_eq)
      have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
      from x have degx: "degree ?x = 1" by simp
      note sf = square_free_factorizationD[OF fact(1)]
      {
        fix a i
        assume ai: "(a,i) \<in> set hs"
        with sf(4) have g0: "g \<noteq> 0" by auto
        from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
        have "a dvd g" unfolding square_free_factorization_prod_list[OF fact(1)] hs
          by (rule dvd_smult, simp add: ac_simps)
        moreover have "\<not> ?x dvd g" using xs[unfolded Suc] by auto
        ultimately have dvd: "\<not> ?x dvd a" using dvd_trans by blast
        from sf(2)[OF ai] have "a \<noteq> 0" by auto
        have "1 = gcd ?x a"
        proof (rule gcdI)
          fix d
          assume d: "d dvd ?x" "d dvd a"
          from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
          show "is_unit d"
          proof (cases "degree d = 1")
            case False
            with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
            from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
            from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
            hence "d * d = 1" unfolding dc by (auto, cases "c = -1"; cases "c = 1", auto)
            thus "is_unit d" by (metis dvd_triv_right)
          next
            case True
            from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
            from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
              by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
            with True have "degree e = 0" by auto
            from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
            from arg_cong[OF this, of content, unfolded content_mult] x
            have "content [:e:] * content d = 1" by auto
            also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
            finally have "\<bar>e\<bar> * content d = 1" .
            from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
            with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
            hence "?x dvd d" unfolding dvd_def by blast
            with d(2) have "?x dvd a" by (metis dvd_trans)
            with dvd show ?thesis by auto
          qed
        qed auto
        hence "coprime ?x a"
          by (simp add: gcd_eq_1_imp_coprime)
        note this dvd
      } note hs_dvd_x = this
      from hs_dvd_x[of ?x m]
      have nmem: "(?x,m) \<notin> set hs" by auto
      hence eq: "?x ^ n * g = smult d (\<Prod>(a, i)\<in>set fs. a ^ Suc i)"
        unfolding sf(1) unfolding id Suc by simp
      have eq0: "?x ^ n * g = 0 \<longleftrightarrow> g = 0" by simp
      have "square_free_factorization f (d,fs)" unfolding fg id(1) square_free_factorization_def split eq0 unfolding eq
      proof (intro conjI allI impI, rule refl)
        fix a i
        assume ai: "(a,i) \<in> set fs"
        thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding id by auto
        fix b j
        assume bj: "(b,j) \<in> set fs" and diff: "(a,i) \<noteq> (b,j)"
        consider (hs_hs) "(a,i) \<in> set hs" "(b,j) \<in> set hs"
          | (hs_x) "(a,i) \<in> set hs" "b = ?x"
          | (x_hs) "(b,j) \<in> set hs" "a = ?x"
          using ai bj diff unfolding id by auto
        thus "Rings.coprime a b"
        proof cases
          case hs_hs
          from sf(3)[OF this diff] show ?thesis .
        next
          case hs_x
          from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2)
            by (simp add: ac_simps)
        next
          case x_hs
          from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2)
            by simp
        qed
      next
        show "g = 0 \<Longrightarrow> d = 0" using sf(4) by auto
        show "g = 0 \<Longrightarrow> fs = []" using sf(4) xs Suc by auto
        show "distinct fs" using sf(5) nmem unfolding id by auto
      qed
      thus ?thesis using one unfolding id by auto
    qed
  qed
qed
end

lift_definition berlekamp_zassenhaus_factorization_algorithm :: int_poly_factorization_algorithm
  is berlekamp_zassenhaus_factorization
  using berlekamp_zassenhaus_factorization_irreducible\<^sub>d by blast

abbreviation factorize_int_poly where
  "factorize_int_poly \<equiv> factorize_int_poly_generic berlekamp_zassenhaus_factorization_algorithm"
end


(* Title:     HOL/MiniML/MiniML.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "MiniML with type inference rules"

theory MiniML
imports Generalize
begin

\<comment> \<open>expressions\<close>
datatype
  expr = Var nat | Abs expr | App expr expr | LET expr expr

\<comment> \<open>type inference rules\<close>
inductive
  has_type :: "[ctxt, expr, typ] => bool"
                  ("((_) |-/ (_) :: (_))" [60,0,60] 60)
where
  VarI: "[| n < length A; t <| A!n |] ==> A |- Var n :: t"
| AbsI: "[| (mk_scheme t1)#A |- e :: t2 |] ==> A |- Abs e :: t1 -> t2"
| AppI: "[| A |- e1 :: t2 -> t1; A |- e2 :: t2 |]
         ==> A |- App e1 e2 :: t1"
| LETI: "[| A |- e1 :: t1; (gen A t1)#A |- e2 :: t |] ==> A |- LET e1 e2 :: t"

declare has_type.intros [simp]
declare Un_upper1 [simp] Un_upper2 [simp]
declare is_bound_typ_instance_closed_subst [simp]

lemma s'_t_equals_s_t:
  "\<And>t::typ. $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) t = $S t"
apply (rule typ_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

declare s'_t_equals_s_t [simp]

lemma s'_a_equals_s_a:
  "\<And>A::type_scheme list. $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then (S n) else (TVar n)) A = $S A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: Ball_def)
done

declare s'_a_equals_s_a [simp]

lemma replace_s_by_s':
 "$(\<lambda>n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) A |-
     e :: $(\<lambda>n. if n : (free_tv A) Un (free_tv t) then S n else TVar n) t
  \<Longrightarrow> $S A |- e :: $S t"
apply (rule_tac P = "\<lambda>A. A |- e :: $S t" in ssubst)
apply (rule s'_a_equals_s_a [symmetric])
apply (rule_tac P = "\<lambda>t. $ (\<lambda>n. if n : free_tv A Un free_tv (t2 S) then S n else TVar n) A |- e :: t" for t2 in ssubst)
apply (rule s'_t_equals_s_t [symmetric])
apply simp
done

lemma alpha_A':
  "\<And>A::type_scheme list. $ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) A = $ id_subst A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: id_subst_def)
done

lemma alpha_A:
  "\<And>A::type_scheme list. $ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) A = A"
apply (rule alpha_A' [THEN ssubst])
apply simp
done

lemma S_o_alpha_typ:
  "$ (S \<circ> alpha) (t::typ) = $ S ($ (\<lambda>x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_typ':
  "$ (\<lambda>u. (S \<circ> alpha) u) (t::typ) = $ S ($ (\<lambda>x. TVar (alpha x)) t)"
apply (induct_tac "t")
apply (simp_all)
done

lemma S_o_alpha_type_scheme:
  "$ (S \<circ> alpha) (sch::type_scheme) = $ S ($ (\<lambda>x. TVar (alpha x)) sch)"
apply (induct_tac "sch")
apply (simp_all)
done

lemma S_o_alpha_type_scheme_list:
  "$ (S \<circ> alpha) (A::type_scheme list) = $ S ($ (\<lambda>x. TVar (alpha x)) A)"
apply (induct_tac "A")
apply (simp_all)
apply (rule S_o_alpha_type_scheme [unfolded o_def])
done

lemma S'_A_eq_S'_alpha_A: "\<And>A::type_scheme list.
      $ (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) A =
      $ ((\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ>
         (\<lambda>x. if x : free_tv A then x else n + x)) A"
apply (subst S_o_alpha_type_scheme_list)
apply (subst alpha_A)
apply (rule refl)
done

lemma dom_S':
 "dom (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
  free_tv A Un free_tv t"
apply (unfold free_tv_subst dom_def)
apply (simp (no_asm))
apply fast
done

lemma cod_S':
  "\<And>(A::type_scheme list) (t::typ).
   cod (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
   free_tv ($ S A) Un free_tv ($ S t)"
apply (unfold free_tv_subst cod_def subset_eq)
apply (rule ballI)
apply (erule UN_E)
apply (drule dom_S' [THEN subsetD])
apply simp
apply (fast dest: free_tv_of_substitutions_extend_to_scheme_lists intro: free_tv_of_substitutions_extend_to_types [THEN subsetD])
done

lemma free_tv_S':
 "\<And>(A::type_scheme list) (t::typ).
  free_tv (\<lambda>n. if n : free_tv A Un free_tv t then S n else TVar n) \<subseteq>
  free_tv A Un free_tv ($ S A) Un free_tv t Un free_tv ($ S t)"
apply (unfold free_tv_subst)
apply (fast dest: dom_S' [THEN subsetD] cod_S' [THEN subsetD])
done

lemma free_tv_alpha: "\<And>t1::typ.
      (free_tv ($ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) t1) - free_tv A) \<subseteq>
          {x. \<exists>y. x = n + y}"
apply (induct_tac "t1")
apply (simp (no_asm))
apply fast
apply (simp (no_asm))
apply fast
done

lemma new_tv_Int_free_tv_empty_type: "\<And>t::typ. new_tv n t \<Longrightarrow> {x. \<exists>y. x = n + y} Int free_tv t = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme: "\<And>sch::type_scheme. new_tv n sch \<Longrightarrow> {x. \<exists>y. x = n + y} Int free_tv sch = {}"
apply safe
apply (cut_tac le_add1)
apply (drule new_tv_le)
apply assumption
apply (rotate_tac 1)
apply (drule new_tv_not_free_tv)
apply fast
done

lemma new_tv_Int_free_tv_empty_scheme_list: "\<forall>A::type_scheme list. new_tv n A \<longrightarrow> {x. \<exists>y. x = n + y} Int free_tv A = {}"
apply (rule allI)
apply (induct_tac "A")
apply (simp (no_asm))
apply (simp (no_asm))
apply (fast dest: new_tv_Int_free_tv_empty_scheme)
done

lemma gen_t_le_gen_alpha_t [rule_format (no_asm)]:
   "new_tv n A \<longrightarrow> gen A t \<le> gen A ($ (\<lambda>x. TVar (if x : free_tv A then x else n + x)) t)"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply (intro strip)
apply (erule exE)
apply (hypsubst)
apply (rule_tac x = " (\<lambda>x. S (if n \<le> x then x - n else x))" in exI)
apply (induct_tac t)
apply (simp (no_asm))
apply (rename_tac nat)
apply (case_tac "nat : free_tv A")
apply (simp (no_asm_simp))
apply (subgoal_tac "n \<le> n + nat")
apply (drule new_tv_le)
apply assumption
apply (drule new_tv_not_free_tv)
apply (drule new_tv_not_free_tv)
apply (simp (no_asm_simp) add: diff_add_inverse)
apply (simp (no_asm))
apply (simp (no_asm_simp))
done

declare has_type.intros [intro!]

lemma has_type_le_env [rule_format (no_asm)]: "A |- e::t \<Longrightarrow> \<forall>B. A \<le> B \<longrightarrow> B |- e::t"
apply (erule has_type.induct)
   apply (simp (no_asm) add: le_env_def)
   apply (fastforce elim: bound_typ_instance_trans)
  apply simp
 apply fast
apply (slow elim: le_env_free_tv [THEN free_tv_subset_gen_le])
done

\<comment> \<open>@{text has_type} is closed w.r.t. substitution\<close>
lemma has_type_cl_sub: "A |- e :: t \<Longrightarrow> \<forall>S. $S A |- e :: $S t"
apply (erule has_type.induct)
(* case VarI *)
   apply (rule allI)
   apply (rule has_type.VarI)
    apply (simp add: app_subst_list)
   apply (simp (no_asm_simp) add: app_subst_list)
  (* case AbsI *)
  apply (rule allI)
  apply (simp (no_asm))
  apply (rule has_type.AbsI)
  apply simp
 (* case AppI *)
 apply (rule allI)
 apply (rule has_type.AppI)
  apply simp
  apply (erule spec)
 apply (erule spec)
(* case LetI *)
apply (rule allI)
apply (rule replace_s_by_s')
apply (cut_tac A = "$ S A" and A' = "A" and t = "t" and t' = "$ S t" in ex_fresh_variable)
apply (erule exE)
apply (erule conjE)+
apply (rule_tac ?t1.0 = "$ ((\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ> (\<lambda>x. if x : free_tv A then x else n + x)) t1" in has_type.LETI)
 apply (drule_tac x = " (\<lambda>x. if x : free_tv A Un free_tv t then S x else TVar x) \<circ> (\<lambda>x. if x : free_tv A then x else n + x) " in spec)
 apply (subst S'_A_eq_S'_alpha_A)
 apply assumption
apply (subst S_o_alpha_typ)
apply (subst gen_subst_commutes)
 apply (rule subset_antisym)
  apply (rule subsetI)
  apply (erule IntE)
  apply (drule free_tv_S' [THEN subsetD])
  apply (drule free_tv_alpha [THEN subsetD])
  apply (simp del: full_SetCompr_eq)
  apply (erule exE)
  apply (hypsubst)
  apply (subgoal_tac "new_tv (n + y) ($ S A) ")
   apply (subgoal_tac "new_tv (n + y) ($ S t) ")
    apply (subgoal_tac "new_tv (n + y) A")
     apply (subgoal_tac "new_tv (n + y) t")
      apply (drule new_tv_not_free_tv)+
      apply fast
     apply (rule new_tv_le) prefer 2 apply assumption apply simp
    apply (rule new_tv_le) prefer 2 apply assumption apply simp
   apply (rule new_tv_le) prefer 2 apply assumption apply simp
  apply (rule new_tv_le) prefer 2 apply assumption apply simp
 apply fast
apply (rule has_type_le_env)
 apply (drule spec)
 apply (drule spec)
 apply assumption
apply (rule app_subst_Cons [THEN subst])
apply (rule S_compatible_le_scheme_lists)
apply (simp (no_asm_simp))
done

end


theory T135
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


header {* The Unit Group *}

theory "UnitGroup"
imports
   "~~/src/HOL/Algebra/Group"
   "Generators"
begin

text {* There is, up to isomorphisms, only one group with one element. *}

definition unit_group :: "unit monoid"
where
  "unit_group \<equiv> \<lparr>
     carrier = UNIV,
     mult = \<lambda> x y. (),
     one = ()
  \<rparr>"

theorem unit_group_is_group: "group unit_group"
  by (rule groupI, auto simp add:unit_group_def)

theorem (in group) unit_group_unique:
  assumes "card (carrier G) = 1"
  shows "\<exists> h. h \<in> G \<cong> unit_group"
proof-
  from assms obtain x where "carrier G = {x}" by (auto dest: card_eq_SucD)
  hence "(\<lambda> x. ()) \<in> G \<cong> unit_group"
    by -(rule group_isoI, auto simp add:unit_group_is_group is_group, simp add:unit_group_def)
  thus ?thesis by auto
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_10
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((t2 m m) = Z)"
  find_proof DInd
  apply (induct m)
   apply auto
  done

end


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

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Z) y = y"
| "plus2 (S z) y = S (plus2 z y)"

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "((plus x (plus y z)) = (plus (plus x y) z))"
  oops

end


theory T90
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T90
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory UTP_Monad
  imports
    "HOL-Library.Monad_Syntax"
begin

text\<open>This is the small theory developed on direct function from a single state space to set of state space.
It is a monadic function and it fulfills the Monadic-laws (right and left identity) and associativity \<close>

text\<open>All definitions here a postfixed with a number to not interfere with the theory below this.\<close>
type_synonym  ('s, 'a) state_unpacked = "'s \<Rightarrow> ('a \<times> 's) set"
context begin

qualified definition return1 :: "'a \<Rightarrow> ('s, 'a) state_unpacked" where
"return1 a \<equiv> (\<lambda>s. {(a,s)})"

lemma run_state_return1[simp]: "(return1 x) s = {(x, s)}"
  unfolding return1_def
  by simp

text\<open>The two bind functions should formally be similar even though they are defined a little differently. But it seems that it is easier to prove with bind version 2 - because where is limited proof support for set-comprehensions\<close>
qualified definition bind1 :: "('s, 'a) state_unpacked \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_unpacked) \<Rightarrow> ('s, 'b) state_unpacked" (infixl ">>=" 60) where
  "bind1 f g \<equiv> \<lambda>s. \<Union>{(g (fst x)) (snd x)|x. x \<in> f s}"

qualified definition bind2 :: "('s, 'a) state_unpacked \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_unpacked) \<Rightarrow> ('s, 'b) state_unpacked" (infixl ">>=" 60) where
  "bind2 f g \<equiv> \<lambda>s. (\<Union>(case_prod g ` (f s)))"

lemma bind1_2_equivalent: "bind1 f g = bind2 f g"
  apply(rule ext)
  unfolding bind2_def bind1_def
  by auto

lemma bind_left_identity2[simp]: "bind2 (return1 a) f = f a"
unfolding return1_def bind2_def by simp

lemma bind_right_identity2[simp]: "bind2 m return1 = m"
  apply(rule ext)
  unfolding return1_def bind2_def
  by simp

lemma bind_left_identity1[simp]: "bind1 (return1 a) f = f a"
unfolding return1_def bind1_def by simp

lemma bind_right_identity1[simp]: "bind1 m return1 = m"
  by (simp add: bind1_2_equivalent)

lemma bind_assoc1: "bind1 (bind1 m f) g = bind1 m (\<lambda>x. bind1 (f x) g)"
  apply (unfold bind1_def split_def)
  apply (rule ext)
  apply clarsimp
  apply (auto intro: rev_image_eqI)
  by blast

qualified definition get1 :: "('s, 's) state_unpacked" where
"get1 = (\<lambda>s. {(s, s)})"

lemma get_

qualified definition set1 :: "'s \<Rightarrow> ('s, unit) state_unpacked" where
"set1 s' = (\<lambda>_. {((), s')})"

lemma set_lemma[simp]: "(set1 s') s = {((), s')}"
unfolding set1_def by simp

lemma get_set[simp]: "bind1 get1 set1 = return1 ()"
  unfolding bind1_def get1_def set1_def return1_def
by simp

lemma set_set_lemma[simp]: "bind1 (set1 s) (\<lambda>_. set1 s') = set1 s'"
unfolding bind1_def set1_def
by simp

lemma get_bind_set_rule[simp]: "bind1 get1 (\<lambda>s. bind1 (set1 s) (f s)) = bind1 get1 (\<lambda>s. f s ())"
unfolding bind1_def get1_def set1_def
by simp

lemma get_const_rule[simp]: "bind1 get1 (\<lambda>_. m) = m"
unfolding get1_def bind1_def
by simp

datatype ('s, 'a) state = State (run_state: "'s \<Rightarrow> ('a \<times> 's) set")

definition set_state:: "('s, 'a) state \<Rightarrow> 'a set" where
  "set_state m = {z. (\<exists>s s'. (z, s') \<in> run_state m s)}"

lemma set_state_iff: "x \<in> set_state m \<longleftrightarrow> (\<exists>s s' z. z = x \<and> (z, s') \<in> run_state m s)"
  by (simp add: set_state_def)

definition pred_state:: "('a \<Rightarrow> bool) \<Rightarrow> ('s, 'a) state \<Rightarrow> bool" where
  "pred_state P m \<equiv> (\<forall>s' s. s' \<in> run_state m s \<longrightarrow> P (fst s'))"

lemma pred_stateI[intro]:
  assumes "\<And>a s s'. (a, s') \<in> run_state m s \<Longrightarrow> P a"
  shows "pred_state P m"
  using assms pred_state_def by force

lemma pred_stateD[dest]:
  assumes "pred_state P m" "(a, s') \<in> run_state m s"
  shows "P a"
  using assms(1) assms(2) pred_state_def by force

lemma pred_state_run_state: "pred_state P m \<Longrightarrow> \<forall>s t. t \<in> (run_state m s) \<longrightarrow> P (fst t)"
  by auto

definition state_io_rel :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s, 'a) state \<Rightarrow> bool" where
"state_io_rel P m = (\<forall>s t. t \<in> ((run_state m s)) \<longrightarrow> P s (snd t))"

lemma state_io_relI[intro]:
  assumes "\<And>s t. t \<in> run_state m s \<Longrightarrow> P s (snd t)"
  shows "state_io_rel P m"
  using assms unfolding state_io_rel_def
  by simp

lemma state_io_relD[dest]:
  assumes "state_io_rel P m" "(a, s') \<in> run_state m s"
  shows "P s s'"
  using assms unfolding state_io_rel_def
by (metis snd_conv)

lemma state_io_rel_mono[mono]: "P \<le> Q \<Longrightarrow> state_io_rel P \<le> state_io_rel Q"
  by (metis predicate1I rev_predicate2D state_io_rel_def)

lemma state_ext:
  assumes "\<And>s. run_state m s = run_state n s"
  shows "m = n"
using assms
by (cases m; cases n) auto

text\<open>The return is quite different but I think it shouldn't be compared to the normal definition\<close>
context begin
qualified definition return :: "'a \<Rightarrow> ('s, 'a) state" where
"return a \<equiv> State (\<lambda>s. {(a,s)})"

lemma run_state_return[simp]: "run_state (return x) s = {(x, s)}"
  unfolding return_def
by simp

text\<open>A set-comprehnsion would probably be the way to go here.\<close>
qualified definition ap :: "('s, 'a \<Rightarrow> 'b) state \<Rightarrow> ('s, 'a) state \<Rightarrow> ('s, 'b) state" where
"ap f x = State (\<lambda>s. case run_state f s of s' \<Rightarrow> case (\<Union>{run_state x (snd t) | t. t \<in> s'}) of s'' \<Rightarrow> {((fst g) (fst y), snd(y)) |y g. y \<in> s'' \<and> g \<in> s'})"

lemma run_state_ap[simp]:
  "run_state (ap f x) s = (case run_state f s  of s' \<Rightarrow> case (\<Union>{run_state x (snd t) | t. t \<in> s'}) of s'' \<Rightarrow> {((fst g) (fst y), snd(y)) |y g. y \<in> s'' \<and> g \<in> s'})"
  unfolding ap_def by auto

qualified definition bind :: "('s, 'a) state \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> ('s, 'b) state" (infixl ">>=" 60) where
(*  "bind f g \<equiv> State(\<lambda>s. \<Union>{run_state (g (fst x)) (snd x)|x. x \<in> (run_state f s)})"*)
  "bind f g = State (bind2 (run_state f) (\<lambda>x. (run_state (g x))))"
text \<open>
  Sometimes it is convenient to write @{text bind} in reverse order.
\<close>

lemma run_state_bind[simp]:
  "run_state (bind x f) s = (case run_state x s of s' \<Rightarrow> \<Union>{run_state (f (fst s'')) (snd s'')|s''. s''\<in> s'})"
  unfolding bind_def bind2_def by auto

adhoc_overloading Monad_Syntax.bind bind

definition
  alternative :: "('s,'a) state \<Rightarrow> ('s,'a) state \<Rightarrow> ('s,'a) state"
  (infixl "OR" 20)
where
  "f OR g \<equiv> State(\<lambda>s. ((run_state f s) \<union> (run_state g s)))"

text \<open>Alternative notation for @{text OR}\<close>
notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

lemma bind_left_identity[simp]: "bind (return a) f = f a"
unfolding return_def bind_def bind2_def by simp

lemma bind_right_identity[simp]: "bind m return = m"
  apply (unfold bind_def)
  apply(rule state_ext)
  by (simp add: List_State_Monad.bind2_def cond_case_prod_eta)

definition
  select :: "'a set \<Rightarrow> ('s,'a) state" where
  "select A \<equiv> State (\<lambda>s. (A \<times> {s}))"

text\<open>The bind function is problematic to do proofs with\<close>
lemma bind_assoc[simp]: "bind (bind m f) g = bind m (\<lambda>x. bind (f x) g)"
  apply (unfold bind_def bind2_def)
  by auto

lemma bind_predI[intro]:
  assumes "pred_state (\<lambda>x. pred_state P (f x)) m"
  shows "pred_state P (bind m f)"
apply (rule pred_stateI)
unfolding bind_def bind2_def
  using assms
  by (metis (mono_tags, lifting) UN_E case_prod_beta fst_conv pred_state_def state.sel)

qualified definition get :: "('s, 's) state" where
"get = State (\<lambda>s. {(s, s)})"

lemma run_state_get[simp]: "run_state get s = {(s, s)}"
unfolding get_def by simp

qualified definition set :: "'s \<Rightarrow> ('s, unit) state" where
"set s' = State (\<lambda>_. {((), s')})"

lemma run_state_set[simp]: "run_state (set s') s = {((), s')}"
unfolding set_def by simp

lemma get_set1[simp]: "bind get set = return ()"
  unfolding bind_def get_def set_def return_def bind2_def
by simp

lemma set_set[simp]: "bind (set s) (\<lambda>_. set s') = set s'"
  unfolding bind_def set_def bind2_def
by simp

lemma get_bind_set[simp]: "bind get (\<lambda>s. bind (set s) (f s)) = bind get (\<lambda>s. f s ())"
unfolding bind_def get_def set_def bind2_def
by simp

lemma get_const[simp]: "bind get (\<lambda>_. m) = m"
unfolding get_def bind_def bind2_def
by simp

fun traverse_list :: "('a \<Rightarrow> ('b, 'c) state) \<Rightarrow> 'a list \<Rightarrow> ('b, 'c list) state" where
"traverse_list _ [] = return []" |
"traverse_list f (x # xs) = do {
  x \<leftarrow> f x;
  xs \<leftarrow> traverse_list f xs;
  return (x # xs)
}"

lemma traverse_list_app[simp]: "traverse_list f (xs @ ys) = do {
  xs \<leftarrow> traverse_list f xs;
  ys \<leftarrow> traverse_list f ys;
  return (xs @ ys)
}"
by (induction xs) auto

lemma traverse_comp[simp]: "traverse_list (g \<circ> f) xs = traverse_list g (map f xs)"
by (induction xs) auto

abbreviation mono_state :: "('s::preorder, 'a) state \<Rightarrow> bool" where
"mono_state \<equiv> state_io_rel (\<le>)"

abbreviation strict_mono_state :: "('s::preorder, 'a) state \<Rightarrow> bool" where
"strict_mono_state \<equiv> state_io_rel (<)"

corollary strict_mono_implies_mono: "strict_mono_state m \<Longrightarrow> mono_state m"
  unfolding state_io_rel_def
  using less_le_not_le by blast

lemma return_mono[simp, intro]: "mono_state (return x)"
  by (simp add: state_io_rel_def)

lemma get_mono[simp, intro]: "mono_state get"
  by (simp add: state_io_rel_def)

lemma put_mono:
  assumes "\<And>x. s' \<ge> x"
  shows "mono_state (set s')"
  using assms unfolding set_def
  by (simp add: state_io_rel_def)

qualified definition update :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) state" where
"update f = bind get (set \<circ> f)"

lemma update_id[simp]: "update (\<lambda>x. x) = return ()"
unfolding update_def return_def get_def set_def bind_def bind2_def
by auto

lemma update_comp[simp]: "bind (update f) (\<lambda>_. update g) = update (g \<circ> f)"
unfolding update_def return_def get_def set_def bind_def bind2_def
by auto

lemma set_update[simp]: "bind (set s) (\<lambda>_. update f) = set (f s)"
unfolding set_def update_def bind_def get_def set_def bind2_def
by simp

lemma set_bind_update[simp]: "bind (set s) (\<lambda>_. bind (update f) g) = bind (set (f s)) g"
unfolding set_def update_def bind_def get_def set_def bind2_def
by simp

lemma update_mono:
  assumes "\<And>x. x \<le> f x"
  shows "mono_state (update f)"
using assms unfolding update_def get_def set_def bind_def bind2_def
by (auto intro!: state_io_relI)

lemma update_strict_mono:
  assumes "\<And>x. x < f x"
  shows "strict_mono_state (update f)"
using assms unfolding update_def get_def set_def bind_def bind2_def
by (auto intro!: state_io_relI)

end

end
end


(*  Title:      HOL/Analysis/Measurable.thy
    Author:     Johannes Hölzl <hoelzl@in.tum.de>
*)
section \<open>Measurability Prover\<close>
theory Measurable
  imports
    Sigma_Algebra
    "HOL-Library.Order_Continuity"
begin

lemma (in algebra) sets_Collect_finite_All:
  assumes "\<And>i. i \<in> S \<Longrightarrow> {x\<in>\<Omega>. P i x} \<in> M" "finite S"
  shows "{x\<in>\<Omega>. \<forall>i\<in>S. P i x} \<in> M"
proof -
  have "{x\<in>\<Omega>. \<forall>i\<in>S. P i x} = (if S = {} then \<Omega> else \<Inter>i\<in>S. {x\<in>\<Omega>. P i x})"
    by auto
  with assms show ?thesis by (auto intro!: sets_Collect_finite_All')
qed

abbreviation "pred M P \<equiv> P \<in> measurable M (count_space (UNIV::bool set))"

lemma pred_def: "pred M P \<longleftrightarrow> {x\<in>space M. P x} \<in> sets M"
proof
  assume "pred M P"
  then have "P -` {True} \<inter> space M \<in> sets M"
    by (auto simp: measurable_count_space_eq2)
  also have "P -` {True} \<inter> space M = {x\<in>space M. P x}" by auto
  finally show "{x\<in>space M. P x} \<in> sets M" .
next
  assume P: "{x\<in>space M. P x} \<in> sets M"
  moreover
  { fix X
    have "X \<in> Pow (UNIV :: bool set)" by simp
    then have "P -` X \<inter> space M = {x\<in>space M. ((X = {True} \<longrightarrow> P x) \<and> (X = {False} \<longrightarrow> \<not> P x) \<and> X \<noteq> {})}"
      unfolding UNIV_bool Pow_insert Pow_empty by auto
    then have "P -` X \<inter> space M \<in> sets M"
      by (auto intro!: sets.sets_Collect_neg sets.sets_Collect_imp sets.sets_Collect_conj sets.sets_Collect_const P) }
  then show "pred M P"
    by (auto simp: measurable_def)
qed

lemma pred_sets1: "{x\<in>space M. P x} \<in> sets M \<Longrightarrow> f \<in> measurable N M \<Longrightarrow> pred N (\<lambda>x. P (f x))"
  by (rule measurable_compose[where f=f and N=M]) (auto simp: pred_def)

lemma pred_sets2: "A \<in> sets N \<Longrightarrow> f \<in> measurable M N \<Longrightarrow> pred M (\<lambda>x. f x \<in> A)"
  by (rule measurable_compose[where f=f and N=N]) (auto simp: pred_def Int_def[symmetric])

ML_file \<open>measurable.ML\<close>

attribute_setup measurable = \<open>
  Scan.lift (
    (Args.add >> K true || Args.del >> K false || Scan.succeed true) --
    Scan.optional (Args.parens (
      Scan.optional (Args.$$$ "raw" >> K true) false --
      Scan.optional (Args.$$$ "generic" >> K Measurable.Generic) Measurable.Concrete))
    (false, Measurable.Concrete) >>
    Measurable.measurable_thm_attr)
\<close> "declaration of measurability theorems"

attribute_setup measurable_dest = Measurable.dest_thm_attr
  "add dest rule to measurability prover"

attribute_setup measurable_cong = Measurable.cong_thm_attr
  "add congurence rules to measurability prover"

method_setup\<^marker>\<open>tag important\<close> measurable = \<open> Scan.lift (Scan.succeed (METHOD o Measurable.measurable_tac)) \<close>
  "measurability prover"

simproc_setup\<^marker>\<open>tag important\<close> measurable ("A \<in> sets M" | "f \<in> measurable M N") = \<open>K Measurable.simproc\<close>

setup \<open>
  Global_Theory.add_thms_dynamic (\<^binding>\<open>measurable\<close>, Measurable.get_all)
\<close>

declare
  pred_sets1[measurable_dest]
  pred_sets2[measurable_dest]
  sets.sets_into_space[measurable_dest]

declare
  sets.top[measurable]
  sets.empty_sets[measurable (raw)]
  sets.Un[measurable (raw)]
  sets.Diff[measurable (raw)]

declare
  measurable_count_space[measurable (raw)]
  measurable_ident[measurable (raw)]
  measurable_id[measurable (raw)]
  measurable_const[measurable (raw)]
  measurable_If[measurable (raw)]
  measurable_comp[measurable (raw)]
  measurable_sets[measurable (raw)]

declare measurable_cong_sets[measurable_cong]
declare sets_restrict_space_cong[measurable_cong]
declare sets_restrict_UNIV[measurable_cong]

lemma predE[measurable (raw)]:
  "pred M P \<Longrightarrow> {x\<in>space M. P x} \<in> sets M"
  unfolding pred_def .

lemma pred_intros_imp'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<longrightarrow> P x)"
  by (cases K) auto

lemma pred_intros_conj1'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<and> P x)"
  by (cases K) auto

lemma pred_intros_conj2'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. P x \<and> K)"
  by (cases K) auto

lemma pred_intros_disj1'[measurable (raw)]:
  "(\<not> K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<or> P x)"
  by (cases K) auto

lemma pred_intros_disj2'[measurable (raw)]:
  "(\<not> K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. P x \<or> K)"
  by (cases K) auto

lemma pred_intros_logic[measurable (raw)]:
  "pred M (\<lambda>x. x \<in> space M)"
  "pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. \<not> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<and> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<longrightarrow> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<or> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x = P x)"
  "pred M (\<lambda>x. f x \<in> UNIV)"
  "pred M (\<lambda>x. f x \<in> {})"
  "pred M (\<lambda>x. P' (f x) x) \<Longrightarrow> pred M (\<lambda>x. f x \<in> {y. P' y x})"
  "pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> - (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) - (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) \<inter> (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) \<union> (B x))"
  "pred M (\<lambda>x. g x (f x) \<in> (X x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (g x) -` (X x))"
  by (auto simp: iff_conv_conj_imp pred_def)

lemma pred_intros_countable[measurable (raw)]:
  fixes P :: "'a \<Rightarrow> 'i :: countable \<Rightarrow> bool"
  shows
    "(\<And>i. pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i. P x i)"
    "(\<And>i. pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i. P x i)"
  by (auto intro!: sets.sets_Collect_countable_All sets.sets_Collect_countable_Ex simp: pred_def)

lemma pred_intros_countable_bounded[measurable (raw)]:
  fixes X :: "'i :: countable set"
  shows
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Inter>i\<in>X. N x i))"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Union>i\<in>X. N x i))"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i\<in>X. P x i)"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i\<in>X. P x i)"
  by simp_all (auto simp: Bex_def Ball_def)

lemma pred_intros_finite[measurable (raw)]:
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Inter>i\<in>I. N x i))"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Union>i\<in>I. N x i))"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i\<in>I. P x i)"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i\<in>I. P x i)"
  by (auto intro!: sets.sets_Collect_finite_Ex sets.sets_Collect_finite_All simp: iff_conv_conj_imp pred_def)

lemma countable_Un_Int[measurable (raw)]:
  "(\<And>i :: 'i :: countable. i \<in> I \<Longrightarrow> N i \<in> sets M) \<Longrightarrow> (\<Union>i\<in>I. N i) \<in> sets M"
  "I \<noteq> {} \<Longrightarrow> (\<And>i :: 'i :: countable. i \<in> I \<Longrightarrow> N i \<in> sets M) \<Longrightarrow> (\<Inter>i\<in>I. N i) \<in> sets M"
  by auto

declare
  finite_UN[measurable (raw)]
  finite_INT[measurable (raw)]

lemma sets_Int_pred[measurable (raw)]:
  assumes space: "A \<inter> B \<subseteq> space M" and [measurable]: "pred M (\<lambda>x. x \<in> A)" "pred M (\<lambda>x. x \<in> B)"
  shows "A \<inter> B \<in> sets M"
proof -
  have "{x\<in>space M. x \<in> A \<inter> B} \<in> sets M" by auto
  also have "{x\<in>space M. x \<in> A \<inter> B} = A \<inter> B"
    using space by auto
  finally show ?thesis .
qed

lemma [measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "c \<in> space N \<Longrightarrow> {c} \<in> sets N"
  shows pred_eq_const1: "pred M (\<lambda>x. f x = c)"
    and pred_eq_const2: "pred M (\<lambda>x. c = f x)"
proof -
  show "pred M (\<lambda>x. f x = c)"
  proof cases
    assume "c \<in> space N"
    with measurable_sets[OF f c] show ?thesis
      by (auto simp: Int_def conj_commute pred_def)
  next
    assume "c \<notin> space N"
    with f[THEN measurable_space] have "{x \<in> space M. f x = c} = {}" by auto
    then show ?thesis by (auto simp: pred_def cong: conj_cong)
  qed
  then show "pred M (\<lambda>x. c = f x)"
    by (simp add: eq_commute)
qed

lemma pred_count_space_const1[measurable (raw)]:
  "f \<in> measurable M (count_space UNIV) \<Longrightarrow> Measurable.pred M (\<lambda>x. f x = c)"
  by (intro pred_eq_const1[where N="count_space UNIV"]) (auto )

lemma pred_count_space_const2[measurable (raw)]:
  "f \<in> measurable M (count_space UNIV) \<Longrightarrow> Measurable.pred M (\<lambda>x. c = f x)"
  by (intro pred_eq_const2[where N="count_space UNIV"]) (auto )

lemma pred_le_const[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{.. c} \<in> sets N" shows "pred M (\<lambda>x. f x \<le> c)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_const_le[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{c ..} \<in> sets N" shows "pred M (\<lambda>x. c \<le> f x)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_less_const[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{..< c} \<in> sets N" shows "pred M (\<lambda>x. f x < c)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_const_less[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{c <..} \<in> sets N" shows "pred M (\<lambda>x. c < f x)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

declare
  sets.Int[measurable (raw)]

lemma pred_in_If[measurable (raw)]:
  "(P \<Longrightarrow> pred M (\<lambda>x. x \<in> A x)) \<Longrightarrow> (\<not> P \<Longrightarrow> pred M (\<lambda>x. x \<in> B x)) \<Longrightarrow>
    pred M (\<lambda>x. x \<in> (if P then A x else B x))"
  by auto

lemma sets_range[measurable_dest]:
  "A ` I \<subseteq> sets M \<Longrightarrow> i \<in> I \<Longrightarrow> A i \<in> sets M"
  by auto

lemma pred_sets_range[measurable_dest]:
  "A ` I \<subseteq> sets N \<Longrightarrow> i \<in> I \<Longrightarrow> f \<in> measurable M N \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_range] by auto

lemma sets_All[measurable_dest]:
  "\<forall>i. A i \<in> sets (M i) \<Longrightarrow> A i \<in> sets (M i)"
  by auto

lemma pred_sets_All[measurable_dest]:
  "\<forall>i. A i \<in> sets (N i) \<Longrightarrow> f \<in> measurable M (N i) \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_All, of A N f] by auto

lemma sets_Ball[measurable_dest]:
  "\<forall>i\<in>I. A i \<in> sets (M i) \<Longrightarrow> i\<in>I \<Longrightarrow> A i \<in> sets (M i)"
  by auto

lemma pred_sets_Ball[measurable_dest]:
  "\<forall>i\<in>I. A i \<in> sets (N i) \<Longrightarrow> i\<in>I \<Longrightarrow> f \<in> measurable M (N i) \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_Ball, of _ _ _ f] by auto

lemma measurable_finite[measurable (raw)]:
  fixes S :: "'a \<Rightarrow> nat set"
  assumes [measurable]: "\<And>i. {x\<in>space M. i \<in> S x} \<in> sets M"
  shows "pred M (\<lambda>x. finite (S x))"
  unfolding finite_nat_set_iff_bounded by (simp add: Ball_def)

lemma measurable_Least[measurable]:
  assumes [measurable]: "(\<And>i::nat. (\<lambda>x. P i x) \<in> measurable M (count_space UNIV))"
  shows "(\<lambda>x. LEAST i. P i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_def by (safe intro!: sets_Least) simp_all

lemma measurable_Max_nat[measurable (raw)]:
  fixes P :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  shows "(\<lambda>x. Max {i. P i x}) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n

  { fix x assume "\<forall>i. \<exists>n\<ge>i. P n x"
    then have "infinite {i. P i x}"
      unfolding infinite_nat_iff_unbounded_le by auto
    then have "Max {i. P i x} = the None"
      by (rule Max.infinite) }
  note 1 = this

  { fix x i j assume "P i x" "\<forall>n\<ge>j. \<not> P n x"
    then have "finite {i. P i x}"
      by (auto simp: subset_eq not_le[symmetric] finite_nat_iff_bounded)
    with \<open>P i x\<close> have "P (Max {i. P i x}) x" "i \<le> Max {i. P i x}" "finite {i. P i x}"
      using Max_in[of "{i. P i x}"] by auto }
  note 2 = this

  have "(\<lambda>x. Max {i. P i x}) -` {n} \<inter> space M = {x\<in>space M. Max {i. P i x} = n}"
    by auto
  also have "\<dots> =
    {x\<in>space M. if (\<forall>i. \<exists>n\<ge>i. P n x) then the None = n else
      if (\<exists>i. P i x) then P n x \<and> (\<forall>i>n. \<not> P i x)
      else Max {} = n}"
    by (intro arg_cong[where f=Collect] ext conj_cong)
       (auto simp add: 1 2 not_le[symmetric] intro!: Max_eqI)
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. Max {i. P i x}) -` {n} \<inter> space M \<in> sets M" .
qed simp

lemma measurable_Min_nat[measurable (raw)]:
  fixes P :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  shows "(\<lambda>x. Min {i. P i x}) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n

  { fix x assume "\<forall>i. \<exists>n\<ge>i. P n x"
    then have "infinite {i. P i x}"
      unfolding infinite_nat_iff_unbounded_le by auto
    then have "Min {i. P i x} = the None"
      by (rule Min.infinite) }
  note 1 = this

  { fix x i j assume "P i x" "\<forall>n\<ge>j. \<not> P n x"
    then have "finite {i. P i x}"
      by (auto simp: subset_eq not_le[symmetric] finite_nat_iff_bounded)
    with \<open>P i x\<close> have "P (Min {i. P i x}) x" "Min {i. P i x} \<le> i" "finite {i. P i x}"
      using Min_in[of "{i. P i x}"] by auto }
  note 2 = this

  have "(\<lambda>x. Min {i. P i x}) -` {n} \<inter> space M = {x\<in>space M. Min {i. P i x} = n}"
    by auto
  also have "\<dots> =
    {x\<in>space M. if (\<forall>i. \<exists>n\<ge>i. P n x) then the None = n else
      if (\<exists>i. P i x) then P n x \<and> (\<forall>i<n. \<not> P i x)
      else Min {} = n}"
    by (intro arg_cong[where f=Collect] ext conj_cong)
       (auto simp add: 1 2 not_le[symmetric] intro!: Min_eqI)
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. Min {i. P i x}) -` {n} \<inter> space M \<in> sets M" .
qed simp

lemma measurable_count_space_insert[measurable (raw)]:
  "s \<in> S \<Longrightarrow> A \<in> sets (count_space S) \<Longrightarrow> insert s A \<in> sets (count_space S)"
  by simp

lemma sets_UNIV [measurable (raw)]: "A \<in> sets (count_space UNIV)"
  by simp

lemma measurable_card[measurable]:
  fixes S :: "'a \<Rightarrow> nat set"
  assumes [measurable]: "\<And>i. {x\<in>space M. i \<in> S x} \<in> sets M"
  shows "(\<lambda>x. card (S x)) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n show "(\<lambda>x. card (S x)) -` {n} \<inter> space M \<in> sets M"
  proof (cases n)
    case 0
    then have "(\<lambda>x. card (S x)) -` {n} \<inter> space M = {x\<in>space M. infinite (S x) \<or> (\<forall>i. i \<notin> S x)}"
      by auto
    also have "\<dots> \<in> sets M"
      by measurable
    finally show ?thesis .
  next
    case (Suc i)
    then have "(\<lambda>x. card (S x)) -` {n} \<inter> space M =
      (\<Union>F\<in>{A\<in>{A. finite A}. card A = n}. {x\<in>space M. (\<forall>i. i \<in> S x \<longleftrightarrow> i \<in> F)})"
      unfolding set_eq_iff[symmetric] Collect_bex_eq[symmetric] by (auto intro: card_ge_0_finite)
    also have "\<dots> \<in> sets M"
      by (intro sets.countable_UN' countable_Collect countable_Collect_finite) auto
    finally show ?thesis .
  qed
qed rule

lemma measurable_pred_countable[measurable (raw)]:
  assumes "countable X"
  shows
    "(\<And>i. i \<in> X \<Longrightarrow> Measurable.pred M (\<lambda>x. P x i)) \<Longrightarrow> Measurable.pred M (\<lambda>x. \<forall>i\<in>X. P x i)"
    "(\<And>i. i \<in> X \<Longrightarrow> Measurable.pred M (\<lambda>x. P x i)) \<Longrightarrow> Measurable.pred M (\<lambda>x. \<exists>i\<in>X. P x i)"
  unfolding pred_def
  by (auto intro!: sets.sets_Collect_countable_All' sets.sets_Collect_countable_Ex' assms)

subsection\<^marker>\<open>tag unimportant\<close> \<open>Measurability for (co)inductive predicates\<close>

lemma measurable_bot[measurable]: "bot \<in> measurable M (count_space UNIV)"
  by (simp add: bot_fun_def)

lemma measurable_top[measurable]: "top \<in> measurable M (count_space UNIV)"
  by (simp add: top_fun_def)

lemma measurable_SUP[measurable]:
  fixes F :: "'i \<Rightarrow> 'a \<Rightarrow> 'b::{complete_lattice, countable}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> measurable M (count_space UNIV)"
  shows "(\<lambda>x. SUP i\<in>I. F i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof (safe intro!: UNIV_I)
  fix a
  have "(\<lambda>x. SUP i\<in>I. F i x) -` {a} \<inter> space M =
    {x\<in>space M. (\<forall>i\<in>I. F i x \<le> a) \<and> (\<forall>b. (\<forall>i\<in>I. F i x \<le> b) \<longrightarrow> a \<le> b)}"
    unfolding SUP_le_iff[symmetric] by auto
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. SUP i\<in>I. F i x) -` {a} \<inter> space M \<in> sets M" .
qed

lemma measurable_INF[measurable]:
  fixes F :: "'i \<Rightarrow> 'a \<Rightarrow> 'b::{complete_lattice, countable}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> measurable M (count_space UNIV)"
  shows "(\<lambda>x. INF i\<in>I. F i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof (safe intro!: UNIV_I)
  fix a
  have "(\<lambda>x. INF i\<in>I. F i x) -` {a} \<inter> space M =
    {x\<in>space M. (\<forall>i\<in>I. a \<le> F i x) \<and> (\<forall>b. (\<forall>i\<in>I. b \<le> F i x) \<longrightarrow> b \<le> a)}"
    unfolding le_INF_iff[symmetric] by auto
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. INF i\<in>I. F i x) -` {a} \<inter> space M \<in> sets M" .
qed

lemma measurable_lfp_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M"
  assumes F: "sup_continuous F"
  assumes *: "\<And>M A. P M \<Longrightarrow> (\<And>N. P N \<Longrightarrow> A \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "lfp F \<in> measurable M (count_space UNIV)"
proof -
  { fix i from \<open>P M\<close> have "((F ^^ i) bot) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M) (auto intro!: *) }
  then have "(\<lambda>x. SUP i. (F ^^ i) bot x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. SUP i. (F ^^ i) bot x) = lfp F"
    by (subst sup_continuous_lfp) (auto intro: F simp: image_comp)
  finally show ?thesis .
qed

lemma measurable_lfp:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes F: "sup_continuous F"
  assumes *: "\<And>A. A \<in> measurable M (count_space UNIV) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "lfp F \<in> measurable M (count_space UNIV)"
  by (coinduction rule: measurable_lfp_coinduct[OF _ F]) (blast intro: *)

lemma measurable_gfp_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M"
  assumes F: "inf_continuous F"
  assumes *: "\<And>M A. P M \<Longrightarrow> (\<And>N. P N \<Longrightarrow> A \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "gfp F \<in> measurable M (count_space UNIV)"
proof -
  { fix i from \<open>P M\<close> have "((F ^^ i) top) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M) (auto intro!: *) }
  then have "(\<lambda>x. INF i. (F ^^ i) top x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. INF i. (F ^^ i) top x) = gfp F"
    by (subst inf_continuous_gfp) (auto intro: F simp: image_comp)
  finally show ?thesis .
qed

lemma measurable_gfp:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes F: "inf_continuous F"
  assumes *: "\<And>A. A \<in> measurable M (count_space UNIV) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "gfp F \<in> measurable M (count_space UNIV)"
  by (coinduction rule: measurable_gfp_coinduct[OF _ F]) (blast intro: *)

lemma measurable_lfp2_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M s"
  assumes F: "sup_continuous F"
  assumes *: "\<And>M A s. P M s \<Longrightarrow> (\<And>N t. P N t \<Longrightarrow> A t \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A s \<in> measurable M (count_space UNIV)"
  shows "lfp F s \<in> measurable M (count_space UNIV)"
proof -
  { fix i from \<open>P M s\<close> have "(\<lambda>x. (F ^^ i) bot s x) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M s) (auto intro!: *) }
  then have "(\<lambda>x. SUP i. (F ^^ i) bot s x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. SUP i. (F ^^ i) bot s x) = lfp F s"
    by (subst sup_continuous_lfp) (auto simp: F simp: image_comp)
  finally show ?thesis .
qed

lemma measurable_gfp2_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M s"
  assumes F: "inf_continuous F"
  assumes *: "\<And>M A s. P M s \<Longrightarrow> (\<And>N t. P N t \<Longrightarrow> A t \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A s \<in> measurable M (count_space UNIV)"
  shows "gfp F s \<in> measurable M (count_space UNIV)"
proof -
  { fix i from \<open>P M s\<close> have "(\<lambda>x. (F ^^ i) top s x) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M s) (auto intro!: *) }
  then have "(\<lambda>x. INF i. (F ^^ i) top s x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. INF i. (F ^^ i) top s x) = gfp F s"
    by (subst inf_continuous_gfp) (auto simp: F simp: image_comp)
  finally show ?thesis .
qed

lemma measurable_enat_coinduct:
  fixes f :: "'a \<Rightarrow> enat"
  assumes "R f"
  assumes *: "\<And>f. R f \<Longrightarrow> \<exists>g h i P. R g \<and> f = (\<lambda>x. if P x then h x else eSuc (g (i x))) \<and>
    Measurable.pred M P \<and>
    i \<in> measurable M M \<and>
    h \<in> measurable M (count_space UNIV)"
  shows "f \<in> measurable M (count_space UNIV)"
proof (simp add: measurable_count_space_eq2_countable, rule )
  fix a :: enat
  have "f -` {a} \<inter> space M = {x\<in>space M. f x = a}"
    by auto
  { fix i :: nat
    from \<open>R f\<close> have "Measurable.pred M (\<lambda>x. f x = enat i)"
    proof (induction i arbitrary: f)
      case 0
      from *[OF this] obtain g h i P
        where f: "f = (\<lambda>x. if P x then h x else eSuc (g (i x)))" and
          [measurable]: "Measurable.pred M P" "i \<in> measurable M M" "h \<in> measurable M (count_space UNIV)"
        by auto
      have "Measurable.pred M (\<lambda>x. P x \<and> h x = 0)"
        by measurable
      also have "(\<lambda>x. P x \<and> h x = 0) = (\<lambda>x. f x = enat 0)"
        by (auto simp: f zero_enat_def[symmetric])
      finally show ?case .
    next
      case (Suc n)
      from *[OF Suc.prems] obtain g h i P
        where f: "f = (\<lambda>x. if P x then h x else eSuc (g (i x)))" and "R g" and
          M[measurable]: "Measurable.pred M P" "i \<in> measurable M M" "h \<in> measurable M (count_space UNIV)"
        by auto
      have "(\<lambda>x. f x = enat (Suc n)) =
        (\<lambda>x. (P x \<longrightarrow> h x = enat (Suc n)) \<and> (\<not> P x \<longrightarrow> g (i x) = enat n))"
        by (auto simp: f zero_enat_def[symmetric] eSuc_enat[symmetric])
      also have "Measurable.pred M \<dots>"
        by (intro pred_intros_logic measurable_compose[OF M(2)] Suc \<open>R g\<close>) measurable
      finally show ?case .
    qed
    then have "f -` {enat i} \<inter> space M \<in> sets M"
      by (simp add: pred_def Int_def conj_commute) }
  note fin = this
  show "f -` {a} \<inter> space M \<in> sets M"
  proof (cases a)
    case infinity
    then have "f -` {a} \<inter> space M = space M - (\<Union>n. f -` {enat n} \<inter> space M)"
      by auto
    also have "\<dots> \<in> sets M"
      by (intro sets.Diff sets.top sets.Un sets.countable_UN) (auto intro!: fin)
    finally show ?thesis .
  qed (simp add: fin)
qed

lemma measurable_THE:
  fixes P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  assumes I[simp]: "countable I" "\<And>i x. x \<in> space M \<Longrightarrow> P i x \<Longrightarrow> i \<in> I"
  assumes unique: "\<And>x i j. x \<in> space M \<Longrightarrow> P i x \<Longrightarrow> P j x \<Longrightarrow> i = j"
  shows "(\<lambda>x. THE i. P i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_def
proof safe
  fix X
  define f where "f x = (THE i. P i x)" for x
  define undef where "undef = (THE i::'a. False)"
  { fix i x assume "x \<in> space M" "P i x" then have "f x = i"
      unfolding f_def using unique by auto }
  note f_eq = this
  { fix x assume "x \<in> space M" "\<forall>i\<in>I. \<not> P i x"
    then have "\<And>i. \<not> P i x"
      using I(2)[of x] by auto
    then have "f x = undef"
      by (auto simp: undef_def f_def) }
  then have "f -` X \<inter> space M = (\<Union>i\<in>I \<inter> X. {x\<in>space M. P i x}) \<union>
     (if undef \<in> X then space M - (\<Union>i\<in>I. {x\<in>space M. P i x}) else {})"
    by (auto dest: f_eq)
  also have "\<dots> \<in> sets M"
    by (auto intro!: sets.Diff sets.countable_UN')
  finally show "f -` X \<inter> space M \<in> sets M" .
qed simp

lemma measurable_Ex1[measurable (raw)]:
  assumes [simp]: "countable I" and [measurable]: "\<And>i. i \<in> I \<Longrightarrow> Measurable.pred M (P i)"
  shows "Measurable.pred M (\<lambda>x. \<exists>!i\<in>I. P i x)"
  unfolding bex1_def by measurable

lemma measurable_Sup_nat[measurable (raw)]:
  fixes F :: "'a \<Rightarrow> nat set"
  assumes [measurable]: "\<And>i. Measurable.pred M (\<lambda>x. i \<in> F x)"
  shows "(\<lambda>x. Sup (F x)) \<in> M \<rightarrow>\<^sub>M count_space UNIV"
proof (clarsimp simp add: measurable_count_space_eq2_countable)
  fix a
  have F_empty_iff: "F x = {} \<longleftrightarrow> (\<forall>i. i \<notin> F x)" for x
    by auto
  have "Measurable.pred M (\<lambda>x. if finite (F x) then if F x = {} then a = 0
    else a \<in> F x \<and> (\<forall>j. j \<in> F x \<longrightarrow> j \<le> a) else a = the None)"
    unfolding finite_nat_set_iff_bounded Ball_def F_empty_iff by measurable
  moreover have "(\<lambda>x. Sup (F x)) -` {a} \<inter> space M =
    {x\<in>space M. if finite (F x) then if F x = {} then a = 0
      else a \<in> F x \<and> (\<forall>j. j \<in> F x \<longrightarrow> j \<le> a) else a = the None}"
    by (intro set_eqI)
       (auto simp: Sup_nat_def Max.infinite intro!: Max_in Max_eqI)
  ultimately show "(\<lambda>x. Sup (F x)) -` {a} \<inter> space M \<in> sets M"
    by auto
qed

lemma measurable_if_split[measurable (raw)]:
  "(c \<Longrightarrow> Measurable.pred M f) \<Longrightarrow> (\<not> c \<Longrightarrow> Measurable.pred M g) \<Longrightarrow>
   Measurable.pred M (if c then f else g)"
  by simp

lemma pred_restrict_space:
  assumes "S \<in> sets M"
  shows "Measurable.pred (restrict_space M S) P \<longleftrightarrow> Measurable.pred M (\<lambda>x. x \<in> S \<and> P x)"
  unfolding pred_def sets_Collect_restrict_space_iff[OF assms] ..

lemma measurable_predpow[measurable]:
  assumes "Measurable.pred M T"
  assumes "\<And>Q. Measurable.pred M Q \<Longrightarrow> Measurable.pred M (R Q)"
  shows "Measurable.pred M ((R ^^ n) T)"
  by (induct n) (auto intro: assms)

lemma measurable_compose_countable_restrict:
  assumes P: "countable {i. P i}"
    and f: "f \<in> M \<rightarrow>\<^sub>M count_space UNIV"
    and Q: "\<And>i. P i \<Longrightarrow> pred M (Q i)"
  shows "pred M (\<lambda>x. P (f x) \<and> Q (f x) x)"
proof -
  have P_f: "{x \<in> space M. P (f x)} \<in> sets M"
    unfolding pred_def[symmetric] by (rule measurable_compose[OF f]) simp
  have "pred (restrict_space M {x\<in>space M. P (f x)}) (\<lambda>x. Q (f x) x)"
  proof (rule measurable_compose_countable'[where g=f, OF _ _ P])
    show "f \<in> restrict_space M {x\<in>space M. P (f x)} \<rightarrow>\<^sub>M count_space {i. P i}"
      by (rule measurable_count_space_extend[OF subset_UNIV])
         (auto simp: space_restrict_space intro!: measurable_restrict_space1 f)
  qed (auto intro!: measurable_restrict_space1 Q)
  then show ?thesis
    unfolding pred_restrict_space[OF P_f] by (simp cong: measurable_cong)
qed

lemma measurable_limsup [measurable (raw)]:
  assumes [measurable]: "\<And>n. A n \<in> sets M"
  shows "limsup A \<in> sets M"
by (subst limsup_INF_SUP, auto)

lemma measurable_liminf [measurable (raw)]:
  assumes [measurable]: "\<And>n. A n \<in> sets M"
  shows "liminf A \<in> sets M"
by (subst liminf_SUP_INF, auto)

lemma measurable_case_enat[measurable (raw)]:
  assumes f: "f \<in> M \<rightarrow>\<^sub>M count_space UNIV" and g: "\<And>i. g i \<in> M \<rightarrow>\<^sub>M N" and h: "h \<in> M \<rightarrow>\<^sub>M N"
  shows "(\<lambda>x. case f x of enat i \<Rightarrow> g i x | \<infinity> \<Rightarrow> h x) \<in> M \<rightarrow>\<^sub>M N"
  apply (rule measurable_compose_countable[OF _ f])
  subgoal for i
    by (cases i) (auto intro: g h)
  done

hide_const (open) pred

end