section \<open>Randomized Algorithms\label{sec:randomized_algorithm}\<close>

text \<open>This section introduces the @{term "random_alg"} monad, that can be used to represent
executable randomized algorithms. It is a type-definition based on the internal representation from
Section~\ref{sec:randomized_algorithm_internal} with the wellformedness restriction.

Additionally, we introduce the @{term "spmf_of_ra"} morphism, which represent the distribution of
a randomized algorithm, under the assumption that the coin flips are independent and unbiased.

We also show that it is a Scott-continuous monad-morphism and introduce transfer theorems, with
which it is possible to establish the corresponding SPMF of a randomized algorithms, even in the
case of (possibly infinite) loops.\<close>

theory Randomized_Algorithm
  imports
    Randomized_Algorithm_Internal
begin

text \<open>A stronger variant of @{thm [source] pmf_eqI}.\<close>

lemma pmf_eq_iff_le:
  fixes p q :: "'a pmf"
  assumes "\<And>x. pmf p x \<le> pmf q x"
  shows "p = q"
proof -
  have "(\<integral>x. pmf q x - pmf p x \<partial>count_space UNIV) = 0"
    by (simp_all add:integrable_pmf integral_pmf)
  moreover have "integrable (count_space UNIV) (\<lambda>x. pmf q x - pmf p x)"
    by (simp add:integrable_pmf)
  moreover  have "AE x in count_space UNIV. 0 \<le> pmf q x - pmf p x"
    using assms unfolding AE_count_space by auto
  ultimately have "AE x in count_space UNIV. pmf q x - pmf p x = 0"
    using integral_nonneg_eq_0_iff_AE by blast
  hence "\<And>x. pmf p x = pmf q x" unfolding AE_count_space by simp
  thus ?thesis by (intro pmf_eqI) auto
qed

text \<open>The following is a stronger variant of @{thm [source] "ord_spmf_eq_pmf_None_eq"}\<close>

lemma eq_iff_ord_spmf:
  assumes "weight_spmf p \<ge> weight_spmf q"
  assumes "ord_spmf (=) p q"
  shows "p = q"
proof -
  have "\<And>x. spmf p x \<le> spmf q x"
    using ord_spmf_eq_leD[OF assms(2)] by simp
  moreover have "pmf p None \<le> pmf q None"
    using assms(1) unfolding pmf_None_eq_weight_spmf by auto
  ultimately have "pmf p x \<le> pmf q x" for x by (cases x) auto
  thus ?thesis using pmf_eq_iff_le by auto
qed

lemma wf_empty: "wf_random (\<lambda>_. None)"
  unfolding wf_random_def by auto

typedef 'a random_alg = "{(r :: 'a random_alg_int). wf_random r}"
  using wf_empty by (intro exI[where x="\<lambda>_. None"]) auto

setup_lifting type_definition_random_alg

lift_definition return_ra :: "'a \<Rightarrow> 'a random_alg" is return_rai
  by (rule wf_return)

lift_definition coin_ra :: "bool random_alg" is coin_rai
  by (rule wf_coin)

lift_definition bind_ra :: "'a random_alg \<Rightarrow> ('a \<Rightarrow> 'b random_alg) \<Rightarrow> 'b random_alg" is bind_rai
  by (rule wf_bind)

adhoc_overloading Monad_Syntax.bind bind_ra

text \<open>Monad laws:\<close>

lemma return_bind_ra:
  "bind_ra (return_ra x) g = g x"
  by (rule return_bind_rai[transferred])

lemma bind_ra_assoc:
  "bind_ra (bind_ra f g) h = bind_ra f (\<lambda>x. bind_ra (g x) h)"
  by (rule bind_rai_assoc[transferred])

lemma bind_return_ra:
  "bind_ra m return_ra = m"
  by (rule bind_return_rai[transferred])

lift_definition lub_ra :: "'a random_alg set \<Rightarrow> 'a random_alg" is
  "(\<lambda>F. if Complete_Partial_Order.chain ord_rai F then lub_rai F else (\<lambda>x. None))"
  using wf_lub wf_empty by auto

lift_definition ord_ra :: "'a random_alg \<Rightarrow> 'a random_alg \<Rightarrow> bool" is "ord_rai" .

lift_definition run_ra :: "'a random_alg \<Rightarrow> coin_stream \<Rightarrow> 'a option" is
  "(\<lambda>f s. map_option fst (f s))" .

context
begin

interpretation pmf_as_measure .

lemma distr_rai_is_pmf:
  assumes "wf_random f"
  shows
    "prob_space (distr_rai f)" (is "?A")
    "sets (distr_rai f) = UNIV" (is "?B")
    "AE x in distr_rai f. measure (distr_rai f) {x} \<noteq> 0" (is "?C")
proof -
  show "prob_space (distr_rai f)"
    using prob_space_distr_rai[OF assms] by simp
  then interpret p: prob_space "distr_rai f"
    by auto
  show ?B
    unfolding distr_rai_def by simp

  have "AE bs in \<B>. map_option fst (f bs) \<in> Some ` range_rm f \<union> {None}"
    unfolding range_rm_def
    by (intro AE_I2) (auto simp:image_iff split:option.split)
  hence "AE x in distr_rai f. x \<in> Some ` range_rm f \<union> {None}"
    unfolding distr_rai_def using distr_rai_measurable[OF assms]
    by (subst AE_distr_iff) auto
  moreover have "countable (Some ` range_rm f \<union> {None})"
    using countable_range[OF assms] by simp
  moreover have "p.events = UNIV"
    unfolding distr_rai_def by simp
  ultimately show ?C
    by (intro iffD2[OF p.AE_support_countable] exI[where x= "Some ` range_rm f \<union> {None}"]) auto
qed

lift_definition spmf_of_ra :: "'a random_alg \<Rightarrow> 'a spmf" is "distr_rai"
  using distr_rai_is_pmf by metis

lemma used_bits_distr_is_pmf:
  assumes "wf_random f"
  shows
    "prob_space (used_bits_distr f)" (is "?A")
    "sets (used_bits_distr f) = UNIV" (is "?B")
    "AE x in used_bits_distr f. measure (used_bits_distr f) {x} \<noteq> 0" (is "?C")
proof -
  show "prob_space (used_bits_distr f)"
    unfolding used_bits_distr_def
    by (intro coin_space.prob_space_distr consumed_bits_measurable)
  then interpret p: prob_space "used_bits_distr f"
    by auto
  show ?B
    unfolding used_bits_distr_def by simp
  have "p.events = UNIV"
    unfolding used_bits_distr_def by simp
  thus ?C
    by (intro iffD2[OF p.AE_support_countable] exI[where x= "UNIV"]) auto
qed

lift_definition coin_usage_of_ra_aux :: "'a random_alg \<Rightarrow> nat spmf" is "used_bits_distr"
  using used_bits_distr_is_pmf by auto

definition coin_usage_of_ra
  where "coin_usage_of_ra p = map_pmf (case_option \<infinity> enat) (coin_usage_of_ra_aux p)"

end

lemma wf_rep_rand_alg:
  "wf_random (Rep_random_alg f)"
  using Rep_random_alg by auto

lemma set_pmf_spmf_of_ra:
  "set_pmf (spmf_of_ra f) \<subseteq> Some ` range_rm (Rep_random_alg f) \<union> {None}"
proof
  let ?f = "Rep_random_alg f"

  fix x assume "x \<in> set_pmf (spmf_of_ra f)"
  hence "pmf (spmf_of_ra f) x > 0"
    using pmf_positive by metis
  hence "measure (distr_rai ?f) {x} > 0"
    by (subst spmf_of_ra.rep_eq[symmetric]) (simp add: pmf.rep_eq)
  hence "0 < measure \<B> {\<omega>. map_option fst (?f \<omega>) = x}"
    using distr_rai_measurable[OF wf_rep_rand_alg] unfolding distr_rai_def
    by (subst (asm) measure_distr) (simp_all add:vimage_def space_coin_space)
  moreover have "{\<omega>. map_option fst (?f \<omega>) = x} = {}" if "x \<notin> range (map_option fst \<circ> ?f)"
    using that by (auto simp:set_eq_iff image_iff)
  hence "measure \<B> {\<omega>. map_option fst (?f \<omega>) = x} = 0" if "x \<notin> range (map_option fst \<circ> ?f)"
    using that by simp
  ultimately have "x \<in> range (map_option fst \<circ> ?f)"
    by auto
  thus "x \<in> Some ` range_rm (Rep_random_alg f) \<union> {None}"
    unfolding range_rm_def by (cases x) auto
qed

lemma spmf_of_ra_return: "spmf_of_ra (return_ra x) = return_spmf x"
proof -
  have "measure_pmf (spmf_of_ra (return_ra x)) = measure_pmf (return_spmf x)"
    unfolding  spmf_of_ra.rep_eq distr_rai_return'[symmetric]
    by (simp add: return_ra.rep_eq)
  thus ?thesis
    using measure_pmf_inject by blast
qed

lemma spmf_of_ra_coin: "spmf_of_ra coin_ra = coin_spmf"
proof -
  have "measure_pmf (spmf_of_ra coin_ra) = measure_pmf coin_spmf"
    unfolding  spmf_of_ra.rep_eq distr_rai_coin[symmetric]
    by (simp add: coin_ra.rep_eq)
  thus ?thesis
    using measure_pmf_inject by blast
qed

lemma spmf_of_ra_bind:
  "spmf_of_ra (bind_ra f g) = bind_spmf (spmf_of_ra f) (\<lambda>x. spmf_of_ra (g x))" (is "?L = ?R")
proof -
  let ?f = "Rep_random_alg f"
  let ?g = "\<lambda>x. Rep_random_alg (g x)"

  have 0: "x \<in> Some ` range_rm ?f \<or> x = None" if "x \<in> set_pmf (spmf_of_ra f)" for x
    using that set_pmf_spmf_of_ra by auto

  have "measure_pmf ?L = distr_rai (?f \<bind> ?g)"
    unfolding spmf_of_ra.rep_eq bind_ra.rep_eq by (simp add:comp_def)
  also have "... = distr_rai ?f \<bind>
    (\<lambda>x. if x \<in> Some ` range_rm ?f then distr_rai (?g (the x)) else return \<D> None)"
    by (intro distr_rai_bind wf_rep_rand_alg)
  also have "... = measure_pmf (spmf_of_ra f) \<bind>
    (\<lambda>x. measure_pmf (if x \<in> Some ` range_rm ?f then spmf_of_ra (g (the x)) else return_pmf None))"
    by (intro arg_cong2[where f="bind"] ext) (auto simp:spmf_of_ra.rep_eq return_discrete)
  also have "... = measure_pmf (spmf_of_ra f \<bind>
    (\<lambda>x. if x \<in> Some ` range_rm ?f then spmf_of_ra (g (the x)) else return_pmf None))"
    unfolding bind_pmf.rep_eq by (simp add:comp_def id_def)
  also have "... = measure_pmf ?R"
    using 0 unfolding bind_spmf_def
    by (intro arg_cong[where f="measure_pmf"] bind_pmf_cong refl) (auto split:option.split)
  finally have "measure_pmf ?L = measure_pmf ?R" by simp
  thus ?thesis
    using measure_pmf_inject by blast
qed

lemma spmf_of_ra_mono:
  assumes "ord_ra f g"
  shows "ord_spmf (=) (spmf_of_ra f) (spmf_of_ra g)"
proof -
  have "ord_rai (Rep_random_alg f) (Rep_random_alg g)"
    using assms unfolding ord_ra.rep_eq by simp
  hence "ennreal (spmf (spmf_of_ra f) x) \<le> ennreal (spmf (spmf_of_ra g) x)" for x
    unfolding emeasure_pmf_single[symmetric] spmf_of_ra.rep_eq
    by (intro distr_rai_ord_rai_mono wf_rep_rand_alg) auto
  hence "spmf (spmf_of_ra f) x \<le> spmf (spmf_of_ra g) x" for x
    by simp
  thus ?thesis
    by (intro ord_pmf_increaseI) auto
qed

lemma spmf_of_ra_lub_ra_empty:
  "spmf_of_ra (lub_ra {}) = return_pmf None" (is "?L = ?R")
proof -
  have "measure_pmf ?L = distr_rai (lub_rai {})"
    unfolding spmf_of_ra.rep_eq lub_ra.rep_eq Complete_Partial_Order.chain_def by auto
  also have "... = distr_rai (\<lambda>_. None)"
    unfolding lub_rai_def fun_lub_def flat_lub_def by auto
  also have "... = measure_pmf ?R"
    unfolding distr_rai_None by simp
  finally have "measure_pmf ?L = measure_pmf ?R"
    by simp
  thus ?thesis
    using measure_pmf_inject by auto
qed

lemma spmf_of_ra_lub_ra:
  fixes A :: "'a random_alg set"
  assumes "Complete_Partial_Order.chain ord_ra A"
  shows "spmf_of_ra (lub_ra A) = lub_spmf (spmf_of_ra ` A)" (is "?L = ?R")
proof (cases "A \<noteq> {}")
  case True
  have 0:"Complete_Partial_Order.chain ord_rai (Rep_random_alg ` A)"
    using assms unfolding ord_ra.rep_eq Complete_Partial_Order.chain_def by auto
  have 1:"Complete_Partial_Order.chain (ord_spmf (=)) (spmf_of_ra ` A)"
    using spmf_of_ra_mono by (intro chain_imageI[OF assms]) auto

  show ?thesis
  proof (rule spmf_eqI)
    fix x :: "'a"
    have "ennreal (spmf ?L x) = emeasure (distr_rai (lub_rai (Rep_random_alg ` A))) {Some x}"
      using 0 unfolding emeasure_pmf_single[symmetric] spmf_of_ra.rep_eq lub_ra.rep_eq by simp
    also have "... = (SUP f\<in>Rep_random_alg ` A. emeasure (distr_rai f) {Some x})"
      using True wf_rep_rand_alg by (intro distr_rai_lub 0) auto
    also have "... = (SUP p\<in>A. ennreal (spmf (spmf_of_ra p) x))"
      unfolding emeasure_pmf_single[symmetric] spmf_of_ra.rep_eq by (simp add:image_image)
    also have "... = (SUP p\<in>spmf_of_ra ` A. ennreal (spmf p x))"
      by (simp add:image_image)
    also have "... = ennreal (spmf ?R x)"
      using True by (intro ennreal_spmf_lub_spmf[symmetric] 1) auto
    finally have "ennreal (spmf ?L x) = ennreal (spmf ?R x)"
      by simp
    thus "spmf ?L x = spmf ?R x"
      by simp
  qed
next
  case False
  thus ?thesis using spmf_of_ra_lub_ra_empty by simp
qed

lemma rep_lub_ra:
  assumes "Complete_Partial_Order.chain ord_ra F"
  shows "Rep_random_alg (lub_ra F) = lub_rai (Rep_random_alg ` F)"
proof -
  have "Complete_Partial_Order.chain ord_rai (Rep_random_alg ` F)"
    using assms unfolding ord_ra.rep_eq Complete_Partial_Order.chain_def by auto
  thus ?thesis
    unfolding lub_ra.rep_eq by simp
qed

lemma partial_function_image_improved:
  fixes ord
  assumes "\<And>A. Complete_Partial_Order.chain ord (f ` A) \<Longrightarrow> l1 (f ` A) = f (l2 A)"
  assumes "partial_function_definitions ord l1"
  assumes "inj f"
  shows "partial_function_definitions (img_ord f ord) l2"
proof -
  interpret pd: partial_function_definitions ord l1
    using assms(2) by auto
  have "img_ord f ord x x" for x
    unfolding img_ord_def using pd.leq_refl by simp
  moreover have "img_ord f ord x z" if "img_ord f ord x y" "img_ord f ord y z"  for x y z
    using that pd.leq_trans unfolding img_ord_def by blast
  moreover have "x = y" if "img_ord f ord x y" "img_ord f ord y x"  for x y
  proof -
    have "f x = f y"
      using that pd.leq_antisym unfolding img_ord_def by blast
    thus ?thesis
      using inj_onD[OF assms(3)] by simp
  qed
  moreover have "img_ord f ord x (l2 A)"
    if "x \<in> A" "Complete_Partial_Order.chain (img_ord f ord) A" for x A
  proof -
    have 0:"Complete_Partial_Order.chain ord (f ` A)"
      using that(2) unfolding chain_def img_ord_def by auto
    have "ord (f x) (l1 (f ` A))"
      using that by (intro pd.lub_upper[OF 0]) auto
    thus ?thesis
      unfolding img_ord_def assms(1)[OF 0] by auto
  qed
  moreover have "img_ord f ord (l2 A) z"
    if "Complete_Partial_Order.chain (img_ord f ord) A" "(\<forall>x. x \<in> A \<longrightarrow> img_ord f ord x z)"
    for z A
  proof -
    have 0:"Complete_Partial_Order.chain ord (f ` A)"
      using that(1) unfolding chain_def img_ord_def by auto
    have "ord (l1 (f ` A)) (f z)"
      using that(2) by (intro pd.lub_least[OF 0]) (auto simp:img_ord_def)
    thus ?thesis
      unfolding img_ord_def assms(1)[OF 0] by auto
  qed
  ultimately show ?thesis
    unfolding partial_function_definitions_def by blast
qed

lemma random_alg_pfd: "partial_function_definitions ord_ra lub_ra"
proof -
  have 0: "inj Rep_random_alg"
    using Rep_random_alg_inject unfolding inj_on_def by auto

  have 1:"partial_function_definitions ord_rai lub_rai"
    using random_alg_int_pd_fact by simp

  have 2:"ord_ra = img_ord Rep_random_alg ord_rai"
    unfolding ord_ra.rep_eq img_ord_def by auto

  show ?thesis
    unfolding 2 by (intro partial_function_image_improved[OF _ 1 0]) (auto simp: lub_ra.rep_eq)
qed

interpretation random_alg_pf: partial_function_definitions "ord_ra" "lub_ra"
  using random_alg_pfd by auto

abbreviation "mono_ra \<equiv> monotone (fun_ord ord_ra) ord_ra"

lemma bind_mono_aux_ra:
  assumes "ord_ra f1 f2" "\<And>y. ord_ra (g1 y) (g2 y)"
  shows "ord_ra (bind_ra f1 g1) (bind_ra f2 g2)"
  using assms unfolding ord_ra.rep_eq bind_ra.rep_eq
  by (intro bind_rai_mono) auto

lemma bind_mono_ra [partial_function_mono]:
  assumes "mono_ra B" and "\<And>y. mono_ra (C y)"
  shows "mono_ra (\<lambda>f. bind_ra (B f) (\<lambda>y. C y f))"
  using assms by (intro monotoneI bind_mono_aux_ra) (auto simp:monotone_def)

definition map_ra :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a random_alg \<Rightarrow> 'b random_alg"
  where "map_ra f p = p \<bind> (\<lambda>x. return_ra (f x))"

lemma spmf_of_ra_map: "spmf_of_ra (map_ra f p) = map_spmf f (spmf_of_ra p)"
  unfolding map_ra_def map_spmf_conv_bind_spmf spmf_of_ra_bind spmf_of_ra_return by simp

lemmas spmf_of_ra_simps =
  spmf_of_ra_return spmf_of_ra_bind spmf_of_ra_coin spmf_of_ra_map

lemma map_mono_ra [partial_function_mono]:
  assumes "mono_ra B"
  shows "mono_ra (\<lambda>f. map_ra g (B f))"
  using assms unfolding map_ra_def by (intro bind_mono_ra) auto

definition rel_spmf_of_ra :: "'a spmf \<Rightarrow> 'a random_alg \<Rightarrow> bool" where
  "rel_spmf_of_ra q p \<longleftrightarrow> q = spmf_of_ra p"

lemma admissible_rel_spmf_of_ra:
  "ccpo.admissible (prod_lub lub_spmf lub_ra) (rel_prod (ord_spmf (=)) ord_ra) (case_prod rel_spmf_of_ra)"
  (is "ccpo.admissible ?lub ?ord ?P")
proof (rule ccpo.admissibleI)
  fix Y
  assume chain: "Complete_Partial_Order.chain ?ord Y"
    and Y: "Y \<noteq> {}"
    and R: "\<forall>(p, q) \<in> Y. rel_spmf_of_ra p q"
  from R have R: "\<And>p q. (p, q) \<in> Y \<Longrightarrow> rel_spmf_of_ra p q" by auto
  have chain1: "Complete_Partial_Order.chain (ord_spmf (=)) (fst ` Y)"
    and chain2: "Complete_Partial_Order.chain (ord_ra) (snd ` Y)"
    using chain by(rule chain_imageI; clarsimp)+
  from Y have Y1: "fst ` Y \<noteq> {}" and Y2: "snd ` Y \<noteq> {}" by auto

  have "lub_spmf (fst ` Y) = lub_spmf (spmf_of_ra ` snd ` Y)"
    unfolding image_image using R
    by (intro arg_cong[of _ _ lub_spmf] image_cong) (auto simp: rel_spmf_of_ra_def)
  also have "\<dots> = spmf_of_ra (lub_ra (snd ` Y))"
    by (intro spmf_of_ra_lub_ra[symmetric] chain2)
  finally have "rel_spmf_of_ra (lub_spmf (fst ` Y)) (lub_ra (snd ` Y))"
    unfolding rel_spmf_of_ra_def .
  then show "?P (?lub Y)"
    by (simp add: prod_lub_def)
qed

lemma admissible_rel_spmf_of_ra_cont [cont_intro]:
  fixes ord
  shows "\<lbrakk> mcont lub ord lub_spmf (ord_spmf (=)) f; mcont lub ord lub_ra ord_ra g \<rbrakk>
  \<Longrightarrow> ccpo.admissible lub ord (\<lambda>x. rel_spmf_of_ra (f x) (g x))"
  by (rule admissible_subst[OF admissible_rel_spmf_of_ra, where f="\<lambda>x. (f x, g x)", simplified])
     (rule mcont_Pair)

lemma mcont2mcont_spmf_of_ra[THEN spmf.mcont2mcont, cont_intro]:
  shows mcont_spmf_of_sampler: "mcont lub_ra ord_ra lub_spmf (ord_spmf (=)) spmf_of_ra"
  unfolding mcont_def monotone_def cont_def
  by (auto simp: spmf_of_ra_mono spmf_of_ra_lub_ra)

context
  includes lifting_syntax
begin

lemma fixp_ra_parametric[transfer_rule]:
  assumes f: "\<And>x. mono_spmf (\<lambda>f. F f x)"
  and g: "\<And>x. mono_ra (\<lambda>f. G f x)"
  and param: "((A ===> rel_spmf_of_ra) ===> A ===> rel_spmf_of_ra) F G"
  shows "(A ===> rel_spmf_of_ra) (spmf.fixp_fun F) (random_alg_pf.fixp_fun G)"
  using f g
proof(rule parallel_fixp_induct_1_1[OF
      partial_function_definitions_spmf random_alg_pfd _ _ reflexive reflexive,
        where P="(A ===> rel_spmf_of_ra)"])
  show "ccpo.admissible (prod_lub (fun_lub lub_spmf) (fun_lub lub_ra))
        (rel_prod (fun_ord (ord_spmf (=))) (fun_ord ord_ra))
        (\<lambda>x. (A ===> rel_spmf_of_ra) (fst x) (snd x))"
    unfolding rel_fun_def
    by(rule admissible_all admissible_imp cont_intro)+
  show "(A ===> rel_spmf_of_ra) (\<lambda>_. lub_spmf {}) (\<lambda>_. lub_ra {})"
    by (auto simp: rel_fun_def rel_spmf_of_ra_def spmf_of_ra_lub_ra_empty)
  show "(A ===> rel_spmf_of_ra) (F f) (G g)" if "(A ===> rel_spmf_of_ra) f g" for f g
    using that by(rule rel_funD[OF param])
qed

lemma return_ra_tranfer[transfer_rule]: "((=) ===> rel_spmf_of_ra) return_spmf return_ra"
  unfolding rel_fun_def rel_spmf_of_ra_def spmf_of_ra_return by simp

lemma bind_ra_tranfer[transfer_rule]:
  "(rel_spmf_of_ra ===> ((=) ===> rel_spmf_of_ra) ===> rel_spmf_of_ra) bind_spmf bind_ra"
  unfolding rel_fun_def rel_spmf_of_ra_def spmf_of_ra_bind by simp presburger

lemma coin_ra_tranfer[transfer_rule]:
  "rel_spmf_of_ra coin_spmf coin_ra"
  unfolding rel_fun_def rel_spmf_of_ra_def spmf_of_ra_coin by simp

lemma map_ra_tranfer[transfer_rule]:
  "((=) ===> rel_spmf_of_ra ===> rel_spmf_of_ra) map_spmf map_ra"
  unfolding rel_fun_def rel_spmf_of_ra_def spmf_of_ra_map by simp

end

declare [[function_internals]]

declaration \<open>Partial_Function.init "random_alg" \<^term>\<open>random_alg_pf.fixp_fun\<close>
  \<^term>\<open>random_alg_pf.mono_body\<close>
  @{thm random_alg_pf.fixp_rule_uc} @{thm random_alg_pf.fixp_induct_uc}
  NONE\<close>

subsection \<open>Almost surely terminating randomized algorithms\<close>

definition terminates_almost_surely :: "'a random_alg \<Rightarrow> bool"
  where "terminates_almost_surely f \<longleftrightarrow> lossless_spmf (spmf_of_ra f)"

definition pmf_of_ra :: "'a random_alg \<Rightarrow> 'a pmf" where
  "pmf_of_ra p = map_pmf the (spmf_of_ra p)"

lemma pmf_of_spmf: "map_pmf the (spmf_of_pmf x) = x"
  by (simp add:map_pmf_comp spmf_of_pmf_def)

definition coin_pmf :: "bool pmf" where "coin_pmf = pmf_of_set UNIV"

lemma pmf_of_ra_coin: "pmf_of_ra (coin_ra) = coin_pmf" (is "?L = ?R")
proof -
  have 0:"spmf_of_ra (coin_ra) = spmf_of_pmf (pmf_of_set UNIV)"
    unfolding spmf_of_ra_coin spmf_of_set_def by simp
  thus ?thesis
    unfolding 0 pmf_of_ra_def pmf_of_spmf coin_pmf_def by simp
qed

lemma pmf_of_ra_return: "pmf_of_ra (return_ra x) = return_pmf x"
  unfolding pmf_of_ra_def spmf_of_ra_return by simp

lemma pmf_of_ra_bind:
  assumes "terminates_almost_surely f"
  shows "pmf_of_ra (f \<bind> g) = pmf_of_ra f \<bind> (\<lambda>x. pmf_of_ra (g x))" (is "?L = ?R")
proof -
  have 0:"x \<noteq> None" if "x \<in> set_pmf (spmf_of_ra f)" for x
    using assms that unfolding terminates_almost_surely_def
    by (meson lossless_iff_set_pmf_None)

  have "?L = spmf_of_ra f \<bind> (\<lambda>x. map_pmf the (case_option (return_pmf None) (spmf_of_ra \<circ> g) x))"
    unfolding pmf_of_ra_def spmf_of_ra_bind bind_spmf_def map_bind_pmf comp_def by simp
  also have "... = spmf_of_ra f \<bind>
    (\<lambda>x. (case x of None \<Rightarrow> return_pmf (the None) | Some x \<Rightarrow> pmf_of_ra (g x)))"
    unfolding map_pmf_def comp_def  pmf_of_ra_def map_pmf_def
    by (intro arg_cong2[where f="bind_pmf"] refl ext) (simp add:bind_return_pmf split:option.split)
  also have "... = spmf_of_ra f \<bind> (\<lambda>x. pmf_of_ra (g (the x)))"
    using 0 by (intro bind_pmf_cong refl) (auto split:option.split)
  also have "... = ?R"
    unfolding pmf_of_ra_def map_pmf_def by (simp add:bind_assoc_pmf bind_return_pmf)
  finally show ?thesis
    by simp
qed

lemma pmf_of_ra_map:
  assumes "terminates_almost_surely m"
  shows "pmf_of_ra (map_ra f m) = map_pmf f (pmf_of_ra m)"
  unfolding map_ra_def pmf_of_ra_bind[OF assms] pmf_of_ra_return map_pmf_def by simp

lemma terminates_almost_surely_return:
  "terminates_almost_surely (return_ra x)"
  unfolding terminates_almost_surely_def spmf_of_ra_return by simp

lemma terminates_almost_surely_coin:
  "terminates_almost_surely coin_ra"
  unfolding terminates_almost_surely_def spmf_of_ra_coin by simp

lemma terminates_almost_surely_bind:
  assumes "terminates_almost_surely f"
  assumes "\<And>x. x \<in> set_pmf (pmf_of_ra f) \<Longrightarrow> terminates_almost_surely (g x)"
  shows "terminates_almost_surely (f \<bind> g)"
proof -
  have 0: "None \<notin> set_pmf (spmf_of_ra f)"
    using assms(1) lossless_iff_set_pmf_None unfolding terminates_almost_surely_def
    by blast
  hence "Some x \<in> set_pmf (spmf_of_ra f) \<longleftrightarrow> x \<in> the ` set_pmf (spmf_of_ra f)" for x
    by (metis image_iff option.collapse option.sel)
  hence "set_spmf (spmf_of_ra f) = set_pmf (pmf_of_ra f)"
    unfolding pmf_of_ra_def set_map_pmf  by (simp add:set_eq_iff set_spmf_def)

  thus ?thesis
    using assms(1,2) unfolding terminates_almost_surely_def spmf_of_ra_bind lossless_bind_spmf
    by auto
qed

lemma terminates_almost_surely_map:
  assumes "terminates_almost_surely p"
  shows "terminates_almost_surely (map_ra f p)"
  unfolding map_ra_def
  by (intro assms terminates_almost_surely_bind terminates_almost_surely_return)

lemmas pmf_of_ra_simps =
  pmf_of_ra_return pmf_of_ra_bind pmf_of_ra_coin pmf_of_ra_map

lemmas terminates_almost_surely_intros =
  terminates_almost_surely_return
  terminates_almost_surely_bind
  terminates_almost_surely_coin
  terminates_almost_surely_map

end


(*
  File:    Puiseux_Polynomial_Library.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Auxiliary material\<close>
subsection \<open>Facts about polynomials\<close>
theory Puiseux_Polynomial_Library
  imports "HOL-Computational_Algebra.Computational_Algebra" "Polynomial_Interpolation.Ring_Hom_Poly"
begin

(* TODO: move a lot of this *)

lemma poly_sum_mset: "poly (\<Sum>x\<in>#A. p x) y = (\<Sum>x\<in>#A. poly (p x) y)"
  by (induction A) auto

lemma poly_prod_mset: "poly (\<Prod>x\<in>#A. p x) y = (\<Prod>x\<in>#A. poly (p x) y)"
  by (induction A) auto

lemma set_mset_subset_singletonD:
  assumes "set_mset A \<subseteq> {x}"
  shows   "A = replicate_mset (size A) x"
  using assms by (induction A) auto

lemma inj_idom_hom_compose [intro]:
  assumes "inj_idom_hom f" "inj_idom_hom g"
  shows   "inj_idom_hom (f \<circ> g)"
proof -
  interpret f: inj_idom_hom f by fact
  interpret g: inj_idom_hom g by fact
  show ?thesis
    by unfold_locales (auto simp: f.hom_add g.hom_add f.hom_mult g.hom_mult)
qed

lemma coeff_pcompose_linear:
  "coeff (pcompose p [:0, a :: 'a :: comm_semiring_1:]) i = a ^ i * coeff p i"
  by (induction p arbitrary: i) (auto simp: pcompose_pCons coeff_pCons mult_ac split: nat.splits)

lemma degree_cong:
  assumes "\<And>i. coeff p i = 0 \<longleftrightarrow> coeff q i = 0"
  shows   "degree p = degree q"
proof -
  have "(\<lambda>n. \<forall>i>n. poly.coeff p i = 0) = (\<lambda>n. \<forall>i>n. poly.coeff q i = 0)"
    using assms by (auto simp: fun_eq_iff)
  thus ?thesis
    by (simp only: degree_def)
qed

lemma coeff_Abs_poly_If_le:
  "coeff (Abs_poly (\<lambda>i. if i \<le> n then f i else 0)) = (\<lambda>i. if i \<le> n then f i else 0)"
proof (rule Abs_poly_inverse, clarify)
  have "eventually (\<lambda>i. i > n) cofinite"
    by (auto simp: MOST_nat)
  thus "eventually (\<lambda>i. (if i \<le> n then f i else 0) = 0) cofinite"
    by eventually_elim auto
qed

lemma coeff_Abs_poly:
  assumes "\<And>i. i > n \<Longrightarrow> f i = 0"
  shows   "coeff (Abs_poly f) = f"
proof (rule Abs_poly_inverse, clarify)
  have "eventually (\<lambda>i. i > n) cofinite"
    by (auto simp: MOST_nat)
  thus "eventually (\<lambda>i. f i = 0) cofinite"
    by eventually_elim (use assms in auto)
qed

lemma (in inj_idom_hom) inj_idom_hom_map_poly [intro]: "inj_idom_hom (map_poly hom)"
proof -
  interpret map_poly_inj_idom_hom hom by unfold_locales
  show ?thesis
    by (simp add: inj_idom_hom_axioms)
qed

lemma inj_idom_hom_pcompose [intro]:
  assumes [simp]: "degree (p :: 'a :: idom poly) \<noteq> 0"
  shows "inj_idom_hom (\<lambda>q. pcompose q p)"
  by unfold_locales (simp_all add: pcompose_eq_0)

lemma degree_sum_less:
  assumes "\<And>x. x \<in> A \<Longrightarrow> degree (f x) < n" "n > 0"
  shows   "degree (sum f A) < n"
  using assms by (induction rule: infinite_finite_induct) (auto intro!: degree_add_less)

lemma degree_lessI:
  assumes "p \<noteq> 0 \<or> n > 0" "\<forall>k\<ge>n. coeff p k = 0"
  shows   "degree p < n"
proof (cases "p = 0")
  case False
  show ?thesis
  proof (rule ccontr)
    assume *: "\<not>(degree p < n)"
    define d where "d = degree p"
    from \<open>p \<noteq> 0\<close> have "coeff p d \<noteq> 0"
      by (auto simp: d_def)
    moreover have "coeff p d = 0"
      using assms(2) * by (auto simp: not_less)
    ultimately show False by contradiction
  qed
qed (use assms in auto)

lemma coeff_linear_poly_power:
  fixes c :: "'a :: semiring_1"
  assumes "i \<le> n"
  shows   "coeff ([:a, b:] ^ n) i = of_nat (n choose i) * b ^ i * a ^ (n - i)"
proof -
  have "[:a, b:] = monom b 1 + [:a:]"
    by (simp add: monom_altdef)
  also have "coeff (\<dots> ^ n) i = (\<Sum>k\<le>n. a^(n-k) * of_nat (n choose k) * (if k = i then b ^ k else 0))"
    by (subst binomial_ring) (simp add: coeff_sum of_nat_poly monom_power poly_const_pow mult_ac)
  also have "\<dots> = (\<Sum>k\<in>{i}. a ^ (n - i) * b ^ i * of_nat (n choose k))"
    using assms by (intro sum.mono_neutral_cong_right) (auto simp: mult_ac)
  finally show *: ?thesis by (simp add: mult_ac)
qed

lemma pcompose_altdef: "pcompose p q = poly (map_poly (\<lambda>x. [:x:]) p) q"
  by (induction p) simp_all

lemma coeff_mult_0: "coeff (p * q) 0 = coeff p 0 * coeff q 0"
  by (simp add: coeff_mult)

lemma coeff_pcompose_0 [simp]:
  "coeff (pcompose p q) 0 = poly p (coeff q 0)"
  by (induction p) (simp_all add: coeff_mult_0)

lemma reducible_polyI:
  fixes p :: "'a :: field poly"
  assumes "p = q * r" "degree q > 0" "degree r > 0"
  shows   "\<not>irreducible p"
  using assms by (auto simp: irreducible_def)

lemma root_imp_reducible_poly:
  fixes x :: "'a :: field"
  assumes "poly p x = 0" and "degree p > 1"
  shows   "\<not>irreducible p"
proof -
  from assms have "p \<noteq> 0"
    by auto
  define q where "q = [:-x, 1:]"
  have "q dvd p"
    using assms by (simp add: poly_eq_0_iff_dvd q_def)
  then obtain r where p_eq: "p = q * r"
    by (elim dvdE)
  have [simp]: "q \<noteq> 0" "r \<noteq> 0"
    using \<open>p \<noteq> 0\<close> by (auto simp: p_eq)
  have "degree p = Suc (degree r)"
    unfolding p_eq by (subst degree_mult_eq) (auto simp: q_def)
  with assms(2) have "degree r > 0"
    by auto
  hence "\<not>is_unit r"
    by auto
  moreover have "\<not>is_unit q"
    by (auto simp: q_def)
  ultimately show ?thesis using p_eq
    by (auto simp: irreducible_def)
qed

subsection \<open>A typeclass for algebraically closed fields\<close>

(* TODO: Move! *)

text \<open>
  Since the required sort constraints are not available inside the class, we have to resort
  to a somewhat awkward way of writing the definition of algebraically closed fields:
\<close>
class alg_closed_field = field +
  assumes alg_closed: "n > 0 \<Longrightarrow> f n \<noteq> 0 \<Longrightarrow> \<exists>x. (\<Sum>k\<le>n. f k * x ^ k) = 0"

text \<open>
  We can then however easily show the equivalence to the proper definition:
\<close>
lemma alg_closed_imp_poly_has_root:
  assumes "degree (p :: 'a :: alg_closed_field poly) > 0"
  shows   "\<exists>x. poly p x = 0"
proof -
  have "\<exists>x. (\<Sum>k\<le>degree p. coeff p k * x ^ k) = 0"
    using assms by (intro alg_closed) auto
  thus ?thesis
    by (simp add: poly_altdef)
qed

lemma alg_closedI [Pure.intro]:
  assumes "\<And>p :: 'a poly. degree p > 0 \<Longrightarrow> lead_coeff p = 1 \<Longrightarrow> \<exists>x. poly p x = 0"
  shows   "OFCLASS('a :: field, alg_closed_field_class)"
proof
  fix n :: nat and f :: "nat \<Rightarrow> 'a"
  assume n: "n > 0" "f n \<noteq> 0"
  define p where "p = Abs_poly (\<lambda>k. if k \<le> n then f k else 0)"
  have coeff_p: "coeff p k = (if k \<le> n then f k else 0)" for k
  proof -
    have "eventually (\<lambda>k. k > n) cofinite"
      by (auto simp: MOST_nat)
    hence "eventually (\<lambda>k. (if k \<le> n then f k else 0) = 0) cofinite"
      by eventually_elim auto
    thus ?thesis
      unfolding p_def by (subst Abs_poly_inverse) auto
  qed

  from n have "degree p \<ge> n"
    by (intro le_degree) (auto simp: coeff_p)
  moreover have "degree p \<le> n"
    by (intro degree_le) (auto simp: coeff_p)
  ultimately have deg_p: "degree p = n"
    by linarith
  from deg_p and n have [simp]: "p \<noteq> 0"
    by auto

  define p' where "p' = smult (inverse (lead_coeff p)) p"
  have deg_p': "degree p' = degree p"
    by (auto simp: p'_def)
  have lead_coeff_p' [simp]: "lead_coeff p' = 1"
    by (auto simp: p'_def)

  from deg_p and deg_p' and n have "degree p' > 0"
    by simp
  from assms[OF this] obtain x where "poly p' x = 0"
    by auto
  hence "poly p x = 0"
    by (simp add: p'_def)
  also have "poly p x = (\<Sum>k\<le>n. f k * x ^ k)"
    unfolding poly_altdef by (intro sum.cong) (auto simp: deg_p coeff_p)
  finally show "\<exists>x. (\<Sum>k\<le>n. f k * x ^ k) = 0" ..
qed

text \<open>
  We can now prove by induction that every polynomial of degree \<open>n\<close> splits into a product of
  \<open>n\<close> linear factors:
\<close>
lemma alg_closed_imp_factorization:
  fixes p :: "'a :: alg_closed_field poly"
  assumes "p \<noteq> 0"
  shows "\<exists>A. size A = degree p \<and> p = smult (lead_coeff p) (\<Prod>x\<in>#A. [:-x, 1:])"
  using assms
proof (induction "degree p" arbitrary: p rule: less_induct)
  case (less p)
  show ?case
  proof (cases "degree p = 0")
    case True
    thus ?thesis
      by (intro exI[of _ "{#}"]) (auto elim!: degree_eq_zeroE)
  next
    case False
    then obtain x where x: "poly p x = 0"
      using alg_closed_imp_poly_has_root by blast
    hence "[:-x, 1:] dvd p"
      using poly_eq_0_iff_dvd by blast
    then obtain q where p_eq: "p = [:-x, 1:] * q"
      by (elim dvdE)
    have "q \<noteq> 0"
      using less.prems p_eq by auto
    moreover from this have deg: "degree p = Suc (degree q)"
      unfolding p_eq by (subst degree_mult_eq) auto
    ultimately obtain A where A: "size A = degree q" "q = smult (lead_coeff q) (\<Prod>x\<in>#A. [:-x, 1:])"
      using less.hyps[of q] by auto
    have "smult (lead_coeff p) (\<Prod>y\<in>#add_mset x A. [:- y, 1:]) =
          [:- x, 1:] * smult (lead_coeff q) (\<Prod>y\<in>#A. [:- y, 1:])"
      unfolding p_eq lead_coeff_mult by simp
    also note A(2) [symmetric]
    also note p_eq [symmetric]
    finally show ?thesis using A(1)
      by (intro exI[of _ "add_mset x A"]) (auto simp: deg)
  qed
qed

text \<open>
  As an alternative characterisation of algebraic closure, one can also say that any
  polynomial of degree at least 2 splits into non-constant factors:
\<close>
lemma alg_closed_imp_reducible:
  assumes "degree (p :: 'a :: alg_closed_field poly) > 1"
  shows   "\<not>irreducible p"
proof -
  have "degree p > 0"
    using assms by auto
  then obtain z where z: "poly p z = 0"
    using alg_closed_imp_poly_has_root[of p] by blast
  then have dvd: "[:-z, 1:] dvd p"
    by (subst dvd_iff_poly_eq_0) auto
  then obtain q where q: "p = [:-z, 1:] * q"
    by (erule dvdE)
  have [simp]: "q \<noteq> 0"
    using assms q by auto

  show ?thesis
  proof (rule reducible_polyI)
    show "p = [:-z, 1:] * q"
      by fact
  next
    have "degree p = degree ([:-z, 1:] * q)"
      by (simp only: q)
    also have "\<dots> = degree q + 1"
      by (subst degree_mult_eq) auto
    finally show "degree q > 0"
      using assms by linarith
  qed auto
qed

text \<open>
  When proving algebraic closure through reducibility, we can assume w.l.o.g. that the polynomial
  is monic and has a non-zero constant coefficient:
\<close>
lemma alg_closedI_reducible:
  assumes "\<And>p :: 'a poly. degree p > 1 \<Longrightarrow> lead_coeff p = 1 \<Longrightarrow> coeff p 0 \<noteq> 0 \<Longrightarrow>
              \<not>irreducible p"
  shows   "OFCLASS('a :: field, alg_closed_field_class)"
proof
  fix p :: "'a poly" assume p: "degree p > 0" "lead_coeff p = 1"
  show "\<exists>x. poly p x = 0"
  proof (cases "coeff p 0 = 0")
    case True
    hence "poly p 0 = 0"
      by (simp add: poly_0_coeff_0)
    thus ?thesis by blast
  next
    case False
    from p and this show ?thesis
    proof (induction "degree p" arbitrary: p rule: less_induct)
      case (less p)
      show ?case
      proof (cases "degree p = 1")
        case True
        then obtain a b where p: "p = [:a, b:]"
          by (cases p) (auto split: if_splits elim!: degree_eq_zeroE)
        from True have [simp]: "b \<noteq> 0"
          by (auto simp: p)
        have "poly p (-a/b) = 0"
          by (auto simp: p)
        thus ?thesis by blast
      next
        case False
        hence "degree p > 1"
          using less.prems by auto
        from assms[OF \<open>degree p > 1\<close> \<open>lead_coeff p = 1\<close> \<open>coeff p 0 \<noteq> 0\<close>]
        have "\<not>irreducible p" by auto
        then obtain r s where rs: "degree r > 0" "degree s > 0" "p = r * s"
          using less.prems by (auto simp: irreducible_def)
        hence "coeff r 0 \<noteq> 0"
          using \<open>coeff p 0 \<noteq> 0\<close> by (auto simp: coeff_mult_0)

        define r' where "r' = smult (inverse (lead_coeff r)) r"
        have [simp]: "degree r' = degree r"
          by (simp add: r'_def)
        have lc: "lead_coeff r' = 1"
          using rs by (auto simp: r'_def)
        have nz: "coeff r' 0 \<noteq> 0"
          using \<open>coeff r 0 \<noteq> 0\<close> by (auto simp: r'_def)

        have "degree r < degree r + degree s"
          using rs by linarith
        also have "\<dots> = degree (r * s)"
          using rs(3) less.prems by (subst degree_mult_eq) auto
        also have "r * s = p"
          using rs(3) by simp
        finally have "\<exists>x. poly r' x = 0"
          by (intro less) (use lc rs nz in auto)
        thus ?thesis
          using rs(3) by (auto simp: r'_def)
      qed
    qed
  qed
qed

text \<open>
  Using a clever Tschirnhausen transformation mentioned e.g. in the article by
  Nowak~\<^cite>\<open>"nowak2000"\<close>, we can also assume w.l.o.g. that the coefficient $a_{n-1}$ is zero.
\<close>
lemma alg_closedI_reducible_coeff_deg_minus_one_eq_0:
  assumes "\<And>p :: 'a poly. degree p > 1 \<Longrightarrow> lead_coeff p = 1 \<Longrightarrow> coeff p (degree p - 1) = 0 \<Longrightarrow>
              coeff p 0 \<noteq> 0 \<Longrightarrow> \<not>irreducible p"
  shows   "OFCLASS('a :: field_char_0, alg_closed_field_class)"
proof (rule alg_closedI_reducible, goal_cases)
  case (1 p)
  define n where [simp]: "n = degree p"
  define a where "a = coeff p (n - 1)"
  define r where "r = [: -a / of_nat n, 1 :]"
  define s where "s = [: a / of_nat n, 1 :]"
  define q where "q = pcompose p r"

  have "n > 0"
    using 1 by simp
  have r_altdef: "r = monom 1 1 + [:-a / of_nat n:]"
    by (simp add: r_def monom_altdef)
  have deg_q: "degree q = n"
    by (simp add: q_def r_def)
  have lc_q: "lead_coeff q = 1"
    unfolding q_def using 1 by (subst lead_coeff_comp) (simp_all add: r_def)
  have "q \<noteq> 0"
    using 1 deg_q by auto

  have "coeff q (n - 1) =
          (\<Sum>i\<le>n. \<Sum>k\<le>i. coeff p i * (of_nat (i choose k) *
            ((-a / of_nat n) ^ (i - k) * (if k = n - 1 then 1 else 0))))"
    unfolding q_def pcompose_altdef poly_altdef r_altdef
    by (simp_all add: degree_map_poly coeff_map_poly coeff_sum binomial_ring sum_distrib_left poly_const_pow
                  sum_distrib_right mult_ac monom_power coeff_monom_mult of_nat_poly cong: if_cong)
  also have "\<dots> = (\<Sum>i\<le>n. \<Sum>k\<in>(if i \<ge> n - 1 then {n-1} else {}).
                     coeff p i * (of_nat (i choose k) * (-a / of_nat n) ^ (i - k)))"
    by (rule sum.cong [OF refl], rule sum.mono_neutral_cong_right) (auto split: if_splits)
  also have "\<dots> = (\<Sum>i\<in>{n-1,n}. \<Sum>k\<in>(if i \<ge> n - 1 then {n-1} else {}).
                     coeff p i * (of_nat (i choose k) * (-a / of_nat n) ^ (i - k)))"
    by (rule sum.mono_neutral_right) auto
  also have "\<dots> = a - of_nat (n choose (n - 1)) * a / of_nat n"
    using 1 by (simp add: a_def)
  also have "n choose (n - 1) = n"
    using \<open>n > 0\<close> by (subst binomial_symmetric) auto
  also have "a - of_nat n * a / of_nat n = 0"
    using \<open>n > 0\<close> by simp
  finally have "coeff q (n - 1) = 0" .

  show ?case
  proof (cases "coeff q 0 = 0")
    case True
    hence "poly p (- (a / of_nat (degree p))) = 0"
      by (auto simp: q_def r_def)
    thus ?thesis
      by (rule root_imp_reducible_poly) (use 1 in auto)
  next
    case False
    hence "\<not>irreducible q"
      using assms[of q] and lc_q and 1 and \<open>coeff q (n - 1) = 0\<close>
      by (auto simp: deg_q)
    then obtain u v where uv: "degree u > 0" "degree v > 0" "q = u * v"
      using \<open>q \<noteq> 0\<close> 1 deg_q by (auto simp: irreducible_def)

    have "p = pcompose q s"
      by (simp add: q_def r_def s_def flip: pcompose_assoc)
    also have "q = u * v"
      by fact
    finally have "p = pcompose u s * pcompose v s"
      by (simp add: pcompose_mult)
    moreover have "degree (pcompose u s) > 0" "degree (pcompose v s) > 0"
      using uv by (simp_all add: s_def)
    ultimately show "\<not>irreducible p"
      using 1 by (intro reducible_polyI)
  qed
qed

text \<open>
  As a consequence of the full factorisation lemma proven above, we can also show that any
  polynomial with at least two different roots splits into two non-constant coprime factors:
\<close>
lemma alg_closed_imp_poly_splits_coprime:
  assumes "degree (p :: 'a :: {alg_closed_field} poly) > 1"
  assumes "poly p x = 0" "poly p y = 0" "x \<noteq> y"
  obtains r s where "degree r > 0" "degree s > 0" "coprime r s" "p = r * s"
proof -
  define n where "n = order x p"
  have "n > 0"
    using assms by (metis degree_0 gr0I n_def not_one_less_zero order_root)
  have "[:-x, 1:] ^ n dvd p"
    unfolding n_def by (simp add: order_1)
  then obtain q where p_eq: "p = [:-x, 1:] ^ n * q"
    by (elim dvdE)
  from assms have [simp]: "q \<noteq> 0"
    by (auto simp: p_eq)
  have "order x p = n + Polynomial.order x q"
    unfolding p_eq by (subst order_mult) (auto simp: order_power_n_n)
  hence "Polynomial.order x q = 0"
    by (simp add: n_def)
  hence "poly q x \<noteq> 0"
    by (simp add: order_root)

  show ?thesis
  proof (rule that)
    show "coprime ([:-x, 1:] ^ n) q"
    proof (rule coprimeI)
      fix d
      assume d: "d dvd [:-x, 1:] ^ n" "d dvd q"
      have "degree d = 0"
      proof (rule ccontr)
        assume "\<not>(degree d = 0)"
        then obtain z where z: "poly d z = 0"
          using alg_closed_imp_poly_has_root by blast
        moreover from this and d(1) have "poly ([:-x, 1:] ^ n) z = 0"
          using dvd_trans poly_eq_0_iff_dvd by blast
        ultimately have "poly d x = 0"
          by auto
        with d(2) have "poly q x = 0"
          using dvd_trans poly_eq_0_iff_dvd by blast
        with \<open>poly q x \<noteq> 0\<close> show False by contradiction
      qed
      thus "is_unit d" using d
        by auto
    qed
  next
    have "poly q y = 0"
      using \<open>poly p y = 0\<close> \<open>x \<noteq> y\<close> by (auto simp: p_eq)
    with \<open>q \<noteq> 0\<close> show "degree q > 0"
      using poly_zero by blast
  qed (use \<open>n > 0\<close> in \<open>simp_all add: p_eq degree_power_eq\<close>)
qed

instance complex :: alg_closed_field
  by standard (use constant_degree fundamental_theorem_of_algebra neq0_conv in blast)

end


subsection \<open>Constructive Chernoff Bound\label{sec:constructive_chernoff_bound}\<close>

text \<open>This section formalizes Theorem~5 by Impagliazzo and Kabanets~\cite{impagliazzo2010}. It is
a general result with which Chernoff-type tail bounds for various kinds of weakly dependent random
variables can be obtained. The results here are general and will be applied in
Section~\ref{sec:random_walks} to random walks in expander graphs.\<close>

theory Constructive_Chernoff_Bound
  imports
    "HOL-Probability.Probability_Measure"
    Frequency_Moments.Product_PMF_Ext
    Weighted_Arithmetic_Geometric_Mean.Weighted_Arithmetic_Geometric_Mean
begin

lemma powr_mono_rev:
  fixes x :: real
  assumes "a \<le> b" and  "x > 0" "x \<le> 1"
  shows "x powr b \<le> x powr a"
proof -
  have "x powr b = (1/x) powr (-b)"
    using assms by (simp add: powr_divide powr_minus_divide)
  also have "... \<le> (1/x) powr (-a)"
    using assms by (intro powr_mono) auto
  also have "... = x powr a"
    using assms by (simp add: powr_divide powr_minus_divide)
  finally show ?thesis by simp
qed

lemma exp_powr: "(exp x) powr y = exp (x*y)" for x :: real
  unfolding powr_def by simp

lemma integrable_pmf_iff_bounded:
  fixes f :: "'a \<Rightarrow> real"
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> abs (f x) \<le> C"
  shows "integrable (measure_pmf p) f"
proof -
  obtain x where "x \<in> set_pmf p"
    using set_pmf_not_empty by fast
  hence "C \<ge> 0" using assms(1) by fastforce
  hence " (\<integral>\<^sup>+ x. ennreal (abs (f x)) \<partial>measure_pmf p) \<le> (\<integral>\<^sup>+ x. C \<partial>measure_pmf p)"
    using assms ennreal_le_iff
    by (intro nn_integral_mono_AE AE_pmfI) auto
  also have "... = C"
    by simp
  also have "... < Orderings.top"
    by simp
  finally have "(\<integral>\<^sup>+ x. ennreal (abs (f x)) \<partial>measure_pmf p) < Orderings.top" by simp
  thus ?thesis
    by (intro iffD2[OF integrable_iff_bounded]) auto
qed

lemma split_pair_pmf:
  "measure_pmf.prob (pair_pmf A B) S = integral\<^sup>L A (\<lambda>a. measure_pmf.prob B {b. (a,b) \<in> S})"
  (is "?L = ?R")
proof -
  have a:"integrable (measure_pmf A) (\<lambda>x. measure_pmf.prob B {b. (x, b) \<in> S})"
    by (intro integrable_pmf_iff_bounded[where C="1"]) simp

  have "?L = (\<integral>\<^sup>+x. indicator S x \<partial>(measure_pmf (pair_pmf A B)))"
    by (simp add: measure_pmf.emeasure_eq_measure)
  also have "... = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. indicator S (x,y) \<partial>B) \<partial>A)"
    by (simp add: nn_integral_pair_pmf')
  also have "... = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. indicator {b. (x,b) \<in> S} y \<partial>B) \<partial>A)"
    by (simp add:indicator_def)
  also have "... = (\<integral>\<^sup>+x. (measure_pmf.prob B {b. (x,b) \<in> S}) \<partial>A)"
    by (simp add: measure_pmf.emeasure_eq_measure)
  also have "... = ?R"
    using a
    by (subst nn_integral_eq_integral) auto
  finally show ?thesis by simp
qed

lemma split_pair_pmf_2:
  "measure(pair_pmf A B) S = integral\<^sup>L B (\<lambda>a. measure_pmf.prob A {b. (b,a) \<in> S})"
  (is "?L = ?R")
proof -
  have "?L = measure (pair_pmf B A) {\<omega>. (snd \<omega>, fst \<omega>) \<in> S}"
    by (subst pair_commute_pmf) (simp add:vimage_def case_prod_beta)
  also have "... = ?R"
    unfolding split_pair_pmf by simp
  finally show ?thesis by simp
qed

definition KL_div :: "real \<Rightarrow> real \<Rightarrow> real"
  where "KL_div p q = p * ln (p/q) + (1-p) * ln ((1-p)/(1-q))"

theorem impagliazzo_kabanets_pmf:
  fixes Y :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  fixes p :: "'a pmf"
  assumes "n > 0"
  assumes "\<And>i. i \<in> {..<n} \<Longrightarrow> \<delta> i \<in> {0..1}"
  assumes "\<And>S. S \<subseteq> {..<n} \<Longrightarrow> measure p {\<omega>. (\<forall>i \<in> S. Y i \<omega>)} \<le> (\<Prod>i \<in> S. \<delta> i)"
  defines "\<delta>_avg \<equiv> (\<Sum>i\<in> {..<n}. \<delta> i)/n"
  assumes "\<gamma> \<in> {\<delta>_avg..1}"
  assumes "\<delta>_avg > 0"
  shows "measure p {\<omega>. real (card {i \<in> {..<n}. Y i \<omega>}) \<ge> \<gamma> * n} \<le> exp (-real n * KL_div \<gamma> \<delta>_avg)"
    (is "?L \<le> ?R")
proof -
  let ?n = "real n"
  define q :: real where "q = (if \<gamma> = 1 then 1 else (\<gamma>-\<delta>_avg)/(\<gamma>*(1-\<delta>_avg)))"

  define g where "g \<omega> = card {i. i < n \<and> \<not>Y i \<omega>}" for \<omega>
  let ?E = "(\<lambda>\<omega>. real (card {i. i < n \<and> Y i \<omega>}) \<ge> \<gamma> * n)"
  let ?\<Xi> = "prod_pmf {..<n} (\<lambda>_. bernoulli_pmf q)"

  have q_range:"q \<in>{0..1}"
  proof (cases "\<gamma> < 1")
    case True
    then show ?thesis
      using assms(5,6)
      unfolding q_def by (auto intro!:divide_nonneg_pos simp add:algebra_simps)
  next
    case False
    hence "\<gamma> = 1" using assms(5) by simp
    then show ?thesis unfolding q_def by simp
  qed

  have abs_pos_le_1I: "abs x \<le> 1" if "x \<ge> 0" "x \<le> 1" for x :: real
    using that by auto

  have \<gamma>_n_nonneg: "\<gamma>*?n \<ge> 0"
    using assms(1,5,6) by simp
  define r where "r = n - nat \<lceil>\<gamma>*n\<rceil>"

  have 2:"(1-q) ^ r \<le> (1-q)^ g \<omega>" if "?E \<omega>" for \<omega>
  proof -
    have "g \<omega> = card ({i. i < n} - {i. i < n \<and> Y i \<omega>})"
      unfolding g_def by (intro arg_cong[where f="\<lambda>x. card x"]) auto
    also have "... = card {i. i < n} - card {i. i < n \<and> Y i \<omega>}"
      by (subst card_Diff_subset, auto)
    also have "... \<le> card {i. i < n} - nat \<lceil>\<gamma>*n\<rceil>"
      using that \<gamma>_n_nonneg by (intro diff_le_mono2) simp
    also have "... = r"
      unfolding r_def by simp
    finally have "g \<omega> \<le> r" by simp
    thus "(1-q) ^ r \<le> (1-q) ^ (g \<omega>)"
      using q_range by (intro power_decreasing) auto
  qed

  have \<gamma>_gt_0: "\<gamma> > 0"
    using assms(5,6) by simp

  have q_lt_1: "q < 1" if "\<gamma> < 1"
  proof -
    have "\<delta>_avg < 1" using assms(5) that by simp
    hence "(\<gamma> - \<delta>_avg) / (\<gamma> * (1 - \<delta>_avg)) < 1"
      using \<gamma>_gt_0 assms(6) that
      by (subst pos_divide_less_eq) (auto simp add:algebra_simps)
    thus "q < 1"
      unfolding q_def using that by simp
  qed

  have 5: "(\<delta>_avg * q + (1-q)) / (1-q) powr (1-\<gamma>) = exp (- KL_div \<gamma> \<delta>_avg)" (is "?L1 = ?R1")
    if "\<gamma> < 1"
  proof -
    have \<delta>_avg_range: "\<delta>_avg \<in> {0<..<1}"
      using that assms(5,6)  by simp

    have "?L1 = (1 - (1-\<delta>_avg) * q) / (1-q) powr (1-\<gamma>)"
      by (simp add:algebra_simps)
    also have "... = (1 - (\<gamma>-\<delta>_avg) / \<gamma> ) / (1-q) powr (1-\<gamma>)"
      unfolding q_def using that \<gamma>_gt_0 \<delta>_avg_range by simp
    also have "... = (\<delta>_avg / \<gamma>) / (1-q) powr (1-\<gamma>)"
      using \<gamma>_gt_0 by (simp add:divide_simps)
    also have "... = (\<delta>_avg / \<gamma>) * (1/(1-q)) powr (1-\<gamma>)"
      using q_lt_1[OF that] by (subst powr_divide, simp_all)
    also have "... = (\<delta>_avg / \<gamma>) * (1/((\<gamma>*(1-\<delta>_avg)-(\<gamma>-\<delta>_avg))/(\<gamma>*(1-\<delta>_avg)))) powr (1-\<gamma>)"
      using \<gamma>_gt_0 \<delta>_avg_range unfolding q_def by (simp add:divide_simps)
    also have "... = (\<delta>_avg / \<gamma>) * ((\<gamma> / \<delta>_avg) *((1-\<delta>_avg)/(1-\<gamma>))) powr (1-\<gamma>)"
      by (simp add:algebra_simps)
    also have "... = (\<delta>_avg / \<gamma>) * (\<gamma> / \<delta>_avg) powr (1-\<gamma>) *((1-\<delta>_avg)/(1-\<gamma>)) powr (1-\<gamma>)"
      using \<gamma>_gt_0  \<delta>_avg_range that by (subst powr_mult, auto)
    also have "... = (\<delta>_avg / \<gamma>) powr 1 * (\<delta>_avg / \<gamma>) powr -(1-\<gamma>) *((1-\<delta>_avg)/(1-\<gamma>)) powr (1-\<gamma>)"
      using \<gamma>_gt_0 \<delta>_avg_range that unfolding powr_minus_divide by (simp add:powr_divide)
    also have "... = (\<delta>_avg / \<gamma>) powr \<gamma> *((1-\<delta>_avg)/(1-\<gamma>)) powr (1-\<gamma>)"
      by (subst powr_add[symmetric]) simp
    also have "... = exp ( ln ((\<delta>_avg / \<gamma>) powr \<gamma> *((1-\<delta>_avg)/(1-\<gamma>)) powr (1-\<gamma>)))"
      using \<gamma>_gt_0 \<delta>_avg_range that by (intro exp_ln[symmetric] mult_pos_pos) auto
    also have "... =  exp ((ln ((\<delta>_avg / \<gamma>) powr \<gamma>) + ln (((1 - \<delta>_avg) / (1 - \<gamma>)) powr (1-\<gamma>))))"
      using \<gamma>_gt_0 \<delta>_avg_range that by (subst ln_mult) auto
    also have "... =  exp ((\<gamma> * ln (\<delta>_avg / \<gamma>) + (1 - \<gamma>) * ln ((1 - \<delta>_avg) / (1 - \<gamma>))))"
      using \<gamma>_gt_0 \<delta>_avg_range that by (simp add:ln_powr algebra_simps)
    also have "... =  exp (- (\<gamma> * ln (\<gamma> / \<delta>_avg) + (1 - \<gamma>) * ln ((1 - \<gamma>) / (1 - \<delta>_avg))))"
      using \<gamma>_gt_0 \<delta>_avg_range that by (simp add: ln_div algebra_simps)
    also have "... = ?R1"
      unfolding KL_div_def by simp

    finally show ?thesis by simp
  qed

  have 3: "(\<delta>_avg * q + (1-q)) ^ n / (1-q) ^ r \<le> exp (- ?n* KL_div \<gamma> \<delta>_avg)" (is "?L1 \<le> ?R1")
  proof (cases "\<gamma> < 1")
    case True
    have "\<gamma> * real n \<le> 1 * real n"
      using True by (intro mult_right_mono) auto
    hence "r = real n - real (nat \<lceil>\<gamma> * real n\<rceil>)"
      unfolding r_def by (subst of_nat_diff) auto
    also have "... = real n - \<lceil>\<gamma> * real n\<rceil>"
      using \<gamma>_n_nonneg by (subst of_nat_nat, auto)
    also have "... \<le> ?n - \<gamma> * ?n"
      by (intro diff_mono) auto
    also have "... = (1-\<gamma>) *?n" by (simp add:algebra_simps)
    finally have r_bound: "r \<le> (1-\<gamma>)*n" by simp

    have "?L1 = (\<delta>_avg * q + (1-q)) ^ n / (1-q) powr r"
      using q_lt_1[OF True] assms(1) by (simp add: powr_realpow)
    also have "... = (\<delta>_avg * q + (1-q)) powr n / (1-q) powr r"
      using q_lt_1[OF True] assms(6) q_range
      by (subst powr_realpow[symmetric], auto intro!:add_nonneg_pos)
    also have "... \<le> (\<delta>_avg * q + (1-q)) powr n / (1-q) powr ((1-\<gamma>)*n)"
      using q_range q_lt_1[OF True] by (intro divide_left_mono powr_mono_rev r_bound) auto
    also have "... = (\<delta>_avg * q + (1-q)) powr n / ((1-q) powr (1-\<gamma>)) powr n"
      unfolding powr_powr by simp
    also have "... = ((\<delta>_avg * q + (1-q)) / (1-q) powr (1-\<gamma>)) powr n"
      using assms(6) q_range by (subst powr_divide) auto
    also have "... = exp (- KL_div \<gamma> \<delta>_avg) powr real n"
      unfolding 5[OF True] by simp
    also have "... = ?R1"
      unfolding exp_powr by simp
    finally show ?thesis by simp
  next
    case False
    hence \<gamma>_eq_1: "\<gamma>=1" using assms(5) by simp
    have "?L1 = \<delta>_avg ^ n"
      using \<gamma>_eq_1 r_def q_def by simp
    also have "... = exp( - KL_div 1 \<delta>_avg) ^ n"
      unfolding KL_div_def using assms(6) by (simp add:ln_div)
    also have "... = ?R1"
      using \<gamma>_eq_1 by (simp add: powr_realpow[symmetric] exp_powr)
    finally show ?thesis by simp
  qed

  have 4: "(1 - q) ^ r > 0"
  proof (cases "\<gamma> < 1")
    case True
    then show ?thesis using q_lt_1[OF True] by simp
  next
    case False
    hence "\<gamma>=1" using assms(5) by simp
    hence "r=0" unfolding r_def by simp
    then show ?thesis by simp
  qed

  have "(1-q) ^ r * ?L = (\<integral>\<omega>. indicator {\<omega>. ?E \<omega>} \<omega> * (1-q) ^ r \<partial>p)"
    by simp
  also have "... \<le> (\<integral>\<omega>. indicator {\<omega>. ?E \<omega>} \<omega> * (1-q) ^ g \<omega> \<partial>p)"
    using q_range 2 by (intro integral_mono_AE integrable_pmf_iff_bounded[where C="1"]
        abs_pos_le_1I mult_le_one power_le_one AE_pmfI) (simp_all split:split_indicator)
  also have "... = (\<integral>\<omega>. indicator {\<omega>. ?E \<omega>} \<omega> * (\<Prod>i \<in> {i. i < n \<and> \<not>Y i \<omega>}. (1-q)) \<partial>p)"
    unfolding g_def using q_range
    by (intro integral_cong_AE AE_pmfI, simp_all add:powr_realpow)
  also have "... = (\<integral>\<omega>. indicator {\<omega>. ?E \<omega>} \<omega> * measure ?\<Xi> ({j. j < n \<and> \<not>Y j \<omega>} \<rightarrow> {False}) \<partial>p)"
    using q_range by (subst prob_prod_pmf') (auto simp add:measure_pmf_single)
  also have "... = (\<integral>\<omega>. measure ?\<Xi> {\<xi>. ?E \<omega> \<and> (\<forall>i\<in>{j. j < n \<and> \<not>Y j \<omega>}. \<not>\<xi> i)} \<partial>p)"
    by (intro integral_cong_AE AE_pmfI, simp_all add:Pi_def split:split_indicator)
  also have "... = (\<integral>\<omega>. measure ?\<Xi> {\<xi>. ?E \<omega> \<and> (\<forall>i\<in>{..<n}. \<xi> i \<longrightarrow> Y i \<omega>)} \<partial>p)"
    by (intro integral_cong_AE AE_pmfI measure_eq_AE) auto
  also have "... = measure (pair_pmf p ?\<Xi>) {\<phi>.?E (fst \<phi>)\<and>(\<forall>i \<in> {..<n}. snd \<phi> i \<longrightarrow> Y i (fst \<phi>))}"
    unfolding split_pair_pmf by simp
  also have "... \<le> measure (pair_pmf p ?\<Xi>) {\<phi>. (\<forall>i \<in> {j. j < n \<and> snd \<phi> j}. Y i (fst \<phi>))}"
    by (intro measure_pmf.pmf_mono[OF refl], auto)
  also have "... = (\<integral>\<xi>. measure p {\<omega>. \<forall>i\<in>{j. j< n \<and> \<xi> j}. Y i \<omega>} \<partial> ?\<Xi>)"
    unfolding split_pair_pmf_2 by simp
  also have "... \<le> (\<integral>a. (\<Prod>i \<in> {j. j < n \<and> a j}. \<delta> i) \<partial> ?\<Xi>)"
    using assms(2) by (intro integral_mono_AE AE_pmfI assms(3) subsetI  prod_le_1 prod_nonneg
        integrable_pmf_iff_bounded[where C="1"] abs_pos_le_1I) auto
  also have "... = (\<integral>a. (\<Prod>i \<in> {..<n}. \<delta> i^ of_bool(a i)) \<partial> ?\<Xi>)"
    unfolding of_bool_def by (intro integral_cong_AE AE_pmfI)
      (auto simp add:if_distrib prod.If_cases Int_def)
  also have "... = (\<Prod>i<n. (\<integral>a. (\<delta> i ^ of_bool a) \<partial>(bernoulli_pmf q)))"
    using assms(2) by (intro expectation_prod_Pi_pmf integrable_pmf_iff_bounded[where C="1"]) auto
  also have "... = (\<Prod>i<n. \<delta> i * q + (1-q))"
    using q_range by simp
  also have "... = (root (card {..<n}) (\<Prod>i<n. \<delta> i * q + (1-q))) ^ (card {..<n})"
    using assms(1,2) q_range by (intro real_root_pow_pos2[symmetric] prod_nonneg) auto
  also have "... \<le> ((\<Sum>i<n. \<delta> i * q + (1-q))/card{..<n})^(card {..<n})"
    using assms(1,2) q_range by (intro power_mono arithmetic_geometric_mean)
      (auto intro: prod_nonneg)
  also have "... = ((\<Sum>i<n. \<delta> i * q)/n + (1-q))^n"
    using assms(1) by (simp add:sum.distrib divide_simps mult.commute)
  also have "... = (\<delta>_avg * q + (1-q))^n"
    unfolding \<delta>_avg_def by (simp add: sum_distrib_right[symmetric])
  finally have "(1-q) ^ r * ?L \<le> (\<delta>_avg * q + (1-q)) ^ n" by simp
  hence "?L \<le> (\<delta>_avg * q + (1-q)) ^ n / (1-q) ^ r"
    using 4 by (subst pos_le_divide_eq) (auto simp add:algebra_simps)
  also have "... \<le> ?R"
    by (intro 3)
  finally show ?thesis by simp
qed

text \<open>The distribution of a random variable with a countable range is a discrete probability space,
i.e., induces a PMF. Using this it is possible to generalize the previous result to arbitrary
probability spaces.\<close>

lemma (in prob_space) establish_pmf:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes rv: "random_variable discrete f"
  assumes "countable (f ` space M)"
  shows "distr M discrete f \<in> {M. prob_space M \<and> sets M = UNIV \<and> (AE x in M. measure M {x} \<noteq> 0)}"
proof -
  define N where "N = {x \<in> space M.\<not> prob (f -` {f x} \<inter> space M) \<noteq> 0}"
  define I where "I = {z \<in> (f ` space M). prob (f -` {z}  \<inter> space M) = 0}"

  have countable_I: " countable I"
    unfolding I_def by (intro countable_subset[OF _ assms(2)]) auto

  have disj: "disjoint_family_on (\<lambda>y. f -` {y} \<inter> space M) I"
    unfolding disjoint_family_on_def by auto

  have N_alt_def: "N = (\<Union>y \<in> I. f -` {y} \<inter> space M)"
    unfolding N_def I_def by (auto simp add:set_eq_iff)
  have "emeasure M N = \<integral>\<^sup>+ y. emeasure M (f -` {y} \<inter> space M) \<partial>count_space I"
    using rv countable_I unfolding N_alt_def
    by (subst emeasure_UN_countable) (auto simp add:disjoint_family_on_def)
  also have "... =  \<integral>\<^sup>+ y. 0 \<partial>count_space I"
    unfolding I_def using emeasure_eq_measure ennreal_0
    by (intro nn_integral_cong) auto
  also have "... = 0" by simp
  finally have 0:"emeasure M N = 0" by simp

  have 1:"N \<in> events"
    unfolding N_alt_def using rv
    by (intro  sets.countable_UN'' countable_I) simp

  have " AE x in M. prob (f -` {f x} \<inter> space M) \<noteq> 0"
    using 0 1 by (subst AE_iff_measurable[OF _ N_def[symmetric]])
  hence " AE x in M. measure (distr M discrete f) {f x} \<noteq> 0"
    by (subst measure_distr[OF rv], auto)
  hence "AE x in distr M discrete f. measure (distr M discrete f) {x} \<noteq> 0"
    by (subst AE_distr_iff[OF rv], auto)
  thus ?thesis
    using prob_space_distr rv by auto
qed

lemma singletons_image_eq:
  "(\<lambda>x. {x}) ` T \<subseteq> Pow T"
  by auto

theorem (in prob_space) impagliazzo_kabanets:
  fixes Y :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  assumes "n > 0"
  assumes "\<And>i. i \<in> {..<n} \<Longrightarrow> random_variable discrete (Y i)"
  assumes "\<And>i. i \<in> {..<n} \<Longrightarrow> \<delta> i \<in> {0..1}"
  assumes "\<And>S. S \<subseteq> {..<n} \<Longrightarrow> \<P>(\<omega> in M. (\<forall>i \<in> S. Y i \<omega>)) \<le> (\<Prod>i \<in> S. \<delta> i)"
  defines "\<delta>_avg \<equiv> (\<Sum>i\<in> {..<n}. \<delta> i)/n"
  assumes "\<gamma> \<in> {\<delta>_avg..1}" "\<delta>_avg > 0"
  shows "\<P>(\<omega> in M. real (card {i \<in> {..<n}. Y i \<omega>}) \<ge> \<gamma> * n) \<le> exp (-real n * KL_div \<gamma> \<delta>_avg)"
    (is "?L \<le> ?R")
proof -
  define f where "f = (\<lambda>\<omega> i. if i < n then Y i \<omega> else False)"
  define g where "g = (\<lambda>\<omega> i. if i < n then \<omega> i else False)"
  define T where "T = {\<omega>. (\<forall>i. \<omega> i \<longrightarrow> i < n)}"

  have g_idem: "g \<circ> f = f" unfolding f_def g_def by (simp add:comp_def)

  have f_range: " f \<in> space M \<rightarrow> T"
    unfolding T_def f_def by simp

  have "T = PiE_dflt {..<n} False (\<lambda>_. UNIV)"
    unfolding T_def PiE_dflt_def by auto
  hence "finite T"
    using finite_PiE_dflt by auto
  hence countable_T: "countable T"
    by (intro countable_finite)
  moreover have "f ` space M \<subseteq> T"
    using f_range by auto
  ultimately have countable_f: "countable (f ` space M)"
    using countable_subset by auto

  have "f -` y \<inter> space M \<in> events" if t:"y \<in> (\<lambda>x. {x}) ` T" for y
  proof -
    obtain t where "y = {t}" and t_range: "t \<in> T" using t by auto
    hence "f -` y \<inter> space M = {\<omega> \<in> space M. f \<omega> = t}"
      by (auto simp add:vimage_def)
    also have "... = {\<omega> \<in> space M. (\<forall>i < n. Y i \<omega> = t i)}"
      using t_range unfolding f_def T_def by auto
    also have "... = (\<Inter>i \<in> {..<n}. {\<omega> \<in> space M. Y i \<omega> = t i})"
      using assms(1) by auto
    also have "... \<in> events"
      using assms(1,2)
      by (intro sets.countable_INT) auto
    finally show ?thesis by simp
  qed

  hence "random_variable (count_space T) f"
    using sigma_sets_singletons[OF countable_T] singletons_image_eq f_range
    by (intro measurable_sigma_sets[where \<Omega>="T" and A=" (\<lambda>x. {x}) ` T"]) simp_all
  moreover have "g \<in> measurable discrete (count_space T)"
    unfolding g_def T_def by simp
  ultimately have "random_variable discrete (g \<circ> f)"
    by simp
  hence rv:"random_variable discrete f"
    unfolding g_idem by simp

  define M' :: "(nat \<Rightarrow> bool) measure"
    where "M' = distr M discrete f"

  define \<Omega> where "\<Omega> = Abs_pmf M'"
  have a:"measure_pmf (Abs_pmf M') = M'"
    unfolding M'_def
    by (intro Abs_pmf_inverse[OF establish_pmf] rv countable_f)

  have b:"{i. (i < n \<longrightarrow> Y i x) \<and> i < n} = {i. i < n \<and> Y i x}" for x
    by auto

  have c: "measure \<Omega> {\<omega>. \<forall>i\<in>S. \<omega> i} \<le> prod \<delta> S" (is "?L1 \<le> ?R1") if "S \<subseteq> {..<n}" for S
  proof -
    have d: "i \<in> S \<Longrightarrow> i < n" for i
      using that by auto
    have "?L1 = measure M' {\<omega>. \<forall>i\<in>S. \<omega> i}"
      unfolding \<Omega>_def a by simp
    also have "... = \<P>(\<omega> in M. (\<forall>i \<in> S. Y i \<omega>))"
      unfolding M'_def using that d
      by (subst measure_distr[OF rv]) (auto simp add:f_def Int_commute Int_def)
    also have "... \<le> ?R1"
      using that assms(4) by simp
    finally show ?thesis by simp
  qed

  have "?L = measure M' {\<omega>. real (card {i. i < n \<and> \<omega> i}) \<ge> \<gamma> * n}"
    unfolding M'_def by (subst measure_distr[OF rv])
      (auto simp add:f_def algebra_simps Int_commute Int_def b)
  also have "... = measure_pmf.prob \<Omega> {\<omega>. real (card {i \<in> {..<n}. \<omega> i}) \<ge> \<gamma> * n}"
    unfolding \<Omega>_def a by simp
  also have "... \<le> ?R"
    using assms(1,3,6,7) c unfolding \<delta>_avg_def
    by (intro impagliazzo_kabanets_pmf) auto
  finally show ?thesis by simp
qed

end


theory E4_1
  imports Main
begin

lemma assumes T: "\<forall> x y. T x y \<or> T y x"
  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof -
  from T A TA `A x y` show "T x y" by blast
qed

end


section \<open>Monad Class\<close>

theory Monad
imports Functor
begin

subsection \<open>Class definition\<close>

text \<open>In Haskell, class \emph{Monad} is defined as follows:\<close>

text_raw \<open>
\begin{verbatim}
class Monad m where
  return :: a -> m a
  (>>=) :: m a -> (a -> m b) -> m b
\end{verbatim}
\<close>

text \<open>We formalize class \<open>monad\<close> in a manner similar to the
\<open>functor\<close> class: We fix monomorphic versions of the class
constants, replacing type variables with \<open>udom\<close>, and assume
monomorphic versions of the class axioms.\<close>

text \<open>Because the monad laws imply the composition rule for \<open>fmap\<close>, we declare \<open>prefunctor\<close> as the superclass, and separately
prove a subclass relationship with \<open>functor\<close>.\<close>

class monad = prefunctor +
  fixes returnU :: "udom \<rightarrow> udom\<cdot>'a::tycon"
  fixes bindU :: "udom\<cdot>'a \<rightarrow> (udom \<rightarrow> udom\<cdot>'a) \<rightarrow> udom\<cdot>'a"
  assumes fmapU_eq_bindU:
    "\<And>f xs. fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
  assumes bindU_returnU:
    "\<And>f x. bindU\<cdot>(returnU\<cdot>x)\<cdot>f = f\<cdot>x"
  assumes bindU_bindU:
    "\<And>xs f g. bindU\<cdot>(bindU\<cdot>xs\<cdot>f)\<cdot>g = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(f\<cdot>x)\<cdot>g)"

instance monad \<subseteq> "functor"
proof
  fix f g :: "udom \<rightarrow> udom" and xs :: "udom\<cdot>'a"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
    by (simp add: fmapU_eq_bindU bindU_bindU bindU_returnU)
qed

text \<open>As with \<open>fmap\<close>, we define the polymorphic \<open>return\<close>
and \<open>bind\<close> by coercion from the monomorphic \<open>returnU\<close> and
\<open>bindU\<close>.\<close>

definition return :: "'a \<rightarrow> 'a\<cdot>'m::monad"
  where "return = coerce\<cdot>(returnU :: udom \<rightarrow> udom\<cdot>'m)"

definition bind :: "'a\<cdot>'m::monad \<rightarrow> ('a \<rightarrow> 'b\<cdot>'m) \<rightarrow> 'b\<cdot>'m"
  where "bind = coerce\<cdot>(bindU :: udom\<cdot>'m \<rightarrow> _)"

abbreviation bind_syn :: "'a\<cdot>'m::monad \<Rightarrow> ('a \<rightarrow> 'b\<cdot>'m) \<Rightarrow> 'b\<cdot>'m" (infixl "\<bind>" 55)
  where "m \<bind> f \<equiv> bind\<cdot>m\<cdot>f"

subsection \<open>Naturality of bind and return\<close>

text \<open>The three class axioms imply naturality properties of \<open>returnU\<close> and \<open>bindU\<close>, i.e., that both commute with \<open>fmapU\<close>.\<close>

lemma fmapU_returnU [coerce_simp]:
  "fmapU\<cdot>f\<cdot>(returnU\<cdot>x) = returnU\<cdot>(f\<cdot>x)"
by (simp add: fmapU_eq_bindU bindU_returnU)

lemma bindU_fmapU:
  "bindU\<cdot>(fmapU\<cdot>f\<cdot>xs)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. k\<cdot>(f\<cdot>x))"
by (simp add: fmapU_eq_bindU bindU_returnU bindU_bindU)

subsection \<open>Polymorphic versions of class assumptions\<close>

lemma monad_fmap:
  fixes xs :: "'a\<cdot>'m::monad" and f :: "'a \<rightarrow> 'b"
  shows "fmap\<cdot>f\<cdot>xs = xs \<bind> (\<Lambda> x. return\<cdot>(f\<cdot>x))"
unfolding bind_def return_def fmap_def
by (simp add: coerce_simp fmapU_eq_bindU bindU_returnU)

lemma monad_left_unit [simp]: "(return\<cdot>x \<bind> f) = (f\<cdot>x)"
unfolding bind_def return_def
by (simp add: coerce_simp bindU_returnU)

lemma bind_bind:
  fixes m :: "'a\<cdot>'m::monad"
  shows "((m \<bind> f) \<bind> g) = (m \<bind> (\<Lambda> x. f\<cdot>x \<bind> g))"
unfolding bind_def
by (simp add: coerce_simp bindU_bindU)

subsection \<open>Derived rules\<close>

text \<open>The following properties can be derived using only the
abstract monad laws.\<close>

lemma monad_right_unit [simp]: "(m \<bind> return) = m"
 apply (subgoal_tac "fmap\<cdot>ID\<cdot>m = m")
  apply (simp only: monad_fmap)
  apply (simp add: eta_cfun)
 apply simp
done

lemma fmap_return: "fmap\<cdot>f\<cdot>(return\<cdot>x) = return\<cdot>(f\<cdot>x)"
by (simp add: monad_fmap)

lemma fmap_bind: "fmap\<cdot>f\<cdot>(bind\<cdot>xs\<cdot>k) = bind\<cdot>xs\<cdot>(\<Lambda> x. fmap\<cdot>f\<cdot>(k\<cdot>x))"
by (simp add: monad_fmap bind_bind)

lemma bind_fmap: "bind\<cdot>(fmap\<cdot>f\<cdot>xs)\<cdot>k = bind\<cdot>xs\<cdot>(\<Lambda> x. k\<cdot>(f\<cdot>x))"
by (simp add: monad_fmap bind_bind)

text \<open>Bind is strict in its first argument, if its second argument
is a strict function.\<close>

lemma bind_strict:
  assumes "k\<cdot>\<bottom> = \<bottom>" shows "\<bottom> \<bind> k = \<bottom>"
proof -
  have "\<bottom> \<bind> k \<sqsubseteq> return\<cdot>\<bottom> \<bind> k"
    by (intro monofun_cfun below_refl minimal)
  thus "\<bottom> \<bind> k = \<bottom>"
    by (simp add: assms)
qed

lemma congruent_bind:
  "(\<forall>m. m \<bind> k1 = m \<bind> k2) = (k1 = k2)"
 apply (safe, rule cfun_eqI)
 apply (drule_tac x="return\<cdot>x" in spec, simp)
done

subsection \<open>Laws for join\<close>

definition join :: "('a\<cdot>'m)\<cdot>'m \<rightarrow> 'a\<cdot>'m::monad"
  where "join \<equiv> \<Lambda> m. m \<bind> (\<Lambda> x. x)"

lemma join_return: "join\<cdot>(return\<cdot>xs) = xs"
by (simp add: join_def)

lemma join_fmap_return: "join\<cdot>(fmap\<cdot>return\<cdot>xs) = xs"
by (simp add: join_def monad_fmap eta_cfun bind_bind)

lemma join_fmap_join: "join\<cdot>(fmap\<cdot>join\<cdot>xsss) = join\<cdot>(join\<cdot>xsss)"
by (simp add: join_def monad_fmap bind_bind)

lemma bind_def2: "m \<bind> k = join\<cdot>(fmap\<cdot>k\<cdot>m)"
by (simp add: join_def monad_fmap eta_cfun bind_bind)

subsection \<open>Equivalence of monad laws and fmap/join laws\<close>

lemma "(return\<cdot>x \<bind> f) = (f\<cdot>x)"
by (simp only: bind_def2 fmap_return join_return)

lemma "(m \<bind> return) = m"
by (simp only: bind_def2 join_fmap_return)

lemma "((m \<bind> f) \<bind> g) = (m \<bind> (\<Lambda> x. f\<cdot>x \<bind> g))"
 apply (simp only: bind_def2)
 apply (subgoal_tac "join\<cdot>(fmap\<cdot>g\<cdot>(join\<cdot>(fmap\<cdot>f\<cdot>m))) =
    join\<cdot>(fmap\<cdot>join\<cdot>(fmap\<cdot>(fmap\<cdot>g)\<cdot>(fmap\<cdot>f\<cdot>m)))")
  apply (simp add: fmap_fmap)
 apply (simp add: join_fmap_join join_fmap_fmap)
done

subsection \<open>Simplification of coercions\<close>

text \<open>We configure rewrite rules that push coercions inwards, and
reduce them to coercions on simpler types.\<close>

lemma coerce_return [coerce_simp]:
  "COERCE('a\<cdot>'m,'b\<cdot>'m::monad)\<cdot>(return\<cdot>x) = return\<cdot>(COERCE('a,'b)\<cdot>x)"
by (simp add: coerce_functor fmap_return)

lemma coerce_bind [coerce_simp]:
  fixes m :: "'a\<cdot>'m::monad" and k :: "'a \<rightarrow> 'b\<cdot>'m"
  shows "COERCE('b\<cdot>'m,'c\<cdot>'m)\<cdot>(m \<bind> k) = m \<bind> (\<Lambda> x. COERCE('b\<cdot>'m,'c\<cdot>'m)\<cdot>(k\<cdot>x))"
by (simp add: coerce_functor fmap_bind)

lemma bind_coerce [coerce_simp]:
  fixes m :: "'a\<cdot>'m::monad" and k :: "'b \<rightarrow> 'c\<cdot>'m"
  shows "COERCE('a\<cdot>'m,'b\<cdot>'m)\<cdot>m \<bind> k = m \<bind> (\<Lambda> x. k\<cdot>(COERCE('a,'b)\<cdot>x))"
by (simp add: coerce_functor bind_fmap)

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_weird_nat_add3_comm23
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

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

end


(*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof of concept for residue rings over int using type numerals\<close>

theory Residue_Ring
  imports MainRLT "HOL-Library.Type_Length"
begin

class len2 = len0 +
  assumes len_ge_2 [iff]: "2 \<le> LENGTH('a)"
begin

subclass len
proof
  show "0 < LENGTH('a)" using len_ge_2
    by arith
qed

lemma len_not_eq_Suc_0 [simp]:
  "LENGTH('a) \<noteq> Suc 0"
  using len_ge_2 by arith

end

instance bit0 and bit1 :: (len) len2
  by standard (simp_all add: Suc_le_eq)

quotient_type (overloaded) 'a residue_ring = int / "\<lambda>k l. k mod int (LENGTH('a)) = l mod int (LENGTH('a::len2))"
  by (auto intro!: equivpI reflpI sympI transpI)

context semiring_1
begin

lift_definition repr :: "'b::len2 residue_ring \<Rightarrow> 'a"
  is "\<lambda>k. of_nat (nat (k mod int (LENGTH('b))))"
  by simp

end

instantiation residue_ring :: (len2) comm_ring_1
begin

lift_definition zero_residue_ring :: "'a residue_ring"
  is 0 .

lift_definition one_residue_ring :: "'a residue_ring"
  is 1 .

lift_definition plus_residue_ring :: "'a residue_ring \<Rightarrow> 'a residue_ring \<Rightarrow> 'a residue_ring"
  is plus
  by (fact mod_add_cong)

lift_definition uminus_residue_ring :: "'a residue_ring \<Rightarrow> 'a residue_ring"
  is uminus
  by (fact mod_minus_cong)

lift_definition minus_residue_ring :: "'a residue_ring \<Rightarrow> 'a residue_ring \<Rightarrow> 'a residue_ring"
  is minus
  by (fact mod_diff_cong)

lift_definition times_residue_ring :: "'a residue_ring \<Rightarrow> 'a residue_ring \<Rightarrow> 'a residue_ring"
  is times
  by (fact mod_mult_cong)

instance
  by (standard; transfer) (simp_all add: algebra_simps mod_eq_0_iff_dvd)

end

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  "((=) ===> pcr_residue_ring) numeral numeral"
  by (rule transfer_rule_numeral; transfer_prover)

lemma [transfer_rule]:
  "((=) ===> pcr_residue_ring) int of_nat"
  by (rule transfer_rule_of_nat; transfer_prover)

end

end


(*
  File: Logic_Thms.thy
  Author: Bohua Zhan

  Setup for proof steps related to logic.
*)

theory Logic_Thms
imports Auto2_HOL
begin

(* Trivial contradictions. *)
setup \<open>add_resolve_prfstep @{thm HOL.refl}\<close>
setup \<open>add_forward_prfstep @{thm contra_triv}\<close>
setup \<open>add_resolve_prfstep @{thm TrueI}\<close>
theorem FalseD [resolve]: "\<not>False" by simp
lemma exists_triv_eq [resolve]: "\<exists>x. x = x" by auto

(* Not. *)
setup \<open>add_forward_prfstep_cond @{thm HOL.not_sym} [with_filt (not_type_filter "s" boolT)]\<close>

(* Iff. *)
setup \<open>add_gen_prfstep ("iff_intro1",
  [WithGoal @{term_pat "(?A::bool) = ?B"},
   CreateCase @{term_pat "?A::bool"},
   WithScore 25])\<close>
theorem iff_goal:
  "A \<noteq> B \<Longrightarrow> A \<Longrightarrow> \<not>B" "A \<noteq> B \<Longrightarrow> B \<Longrightarrow> \<not>A"
  "A \<noteq> B \<Longrightarrow> \<not>A \<Longrightarrow> B" "A \<noteq> B \<Longrightarrow> \<not>B \<Longrightarrow> A"
  "(\<not>A) \<noteq> B \<Longrightarrow> A \<Longrightarrow> B" "A \<noteq> (\<not>B) \<Longrightarrow> B \<Longrightarrow> A" by auto
setup \<open>fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal}\<close>

(* Quantifiers: normalization *)
theorem exists_split: "(\<exists>x y. P x \<and> Q y) = ((\<exists>x. P x) \<and> (\<exists>y. Q y))" by simp
setup \<open>add_backward_prfstep (equiv_backward_th @{thm exists_split})\<close>

(* Case analysis. *)
setup \<open>add_gen_prfstep ("case_intro",
  [WithTerm @{term_pat "if ?cond then (?yes::?'a) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_fact",
  [WithFact @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_goal",
  [WithGoal @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
lemma if_eval':
  "P \<Longrightarrow> (if \<not>P then x else y) = y" by auto
lemma ifb_eval:
  "P \<Longrightarrow> (if P then (x::bool) else y) = x"
  "\<not>P \<Longrightarrow> (if P then (x::bool) else y) = y"
  "P \<Longrightarrow> (if \<not>P then (x::bool) else y) = y" by auto
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1])
  ([@{thm HOL.if_P}, @{thm HOL.if_not_P}, @{thm if_eval'}] @ @{thms ifb_eval})\<close>

(* THE and \<exists>! *)
setup \<open>add_forward_prfstep_cond @{thm theI'} [with_term "THE x. ?P x"]\<close>
setup \<open>add_gen_prfstep ("ex1_case",
  [WithGoal @{term_pat "\<exists>!x. ?P x"}, CreateConcl @{term_pat "\<exists>x. ?P x"}])\<close>
theorem ex_ex1I' [backward1]: "\<forall>y. P y \<longrightarrow> x = y \<Longrightarrow> P x \<Longrightarrow> \<exists>!x. P x" by auto
theorem the1_equality': "P a \<Longrightarrow> \<exists>!x. P x \<Longrightarrow> (THE x. P x) = a" by (simp add: the1_equality)
setup \<open>add_forward_prfstep_cond @{thm the1_equality'} [with_term "THE x. ?P x"]\<close>

(* Hilbert choice. *)
setup \<open>add_gen_prfstep ("SOME_case_intro",
  [WithTerm @{term_pat "SOME k. ?P k"}, CreateConcl @{term_pat "\<exists>k. ?P k"}])\<close>
setup \<open>add_forward_prfstep_cond @{thm someI} [with_term "SOME x. ?P x"]\<close>
setup \<open>add_forward_prfstep_cond @{thm someI_ex} [with_term "SOME x. ?P x"]\<close>

(* Axiom of choice *)
setup \<open>add_prfstep_custom ("ex_choice",
  [WithGoal @{term_pat "EX f. !x. ?Q f x"}],
  (fn ((id, _), ths) => fn _ => fn _ =>
    let
      val choice = @{thm choice} |> apply_to_thm (Conv.rewr_conv UtilBase.backward_conv_th)
    in
      [Update.thm_update (id, (ths MRS choice))]
    end
    handle THM _ => []))
\<close>

(* Least operator. *)
theorem Least_equality' [backward1]:
  "P (x::('a::order)) \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Least P = x" by (simp add: Least_equality)

(* Pairs. *)
lemma pair_inj: "(a,b) = c \<longleftrightarrow> a = fst c \<and> b = snd c" by auto
setup \<open>Normalizer.add_inj_struct_data @{thm pair_inj}\<close>

setup \<open>add_rewrite_rule @{thm fst_conv}\<close>
setup \<open>add_rewrite_rule @{thm snd_conv}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm prod.simps(1)})\<close>
setup \<open>add_rewrite_rule_cond @{thm surjective_pairing} [with_cond "?t \<noteq> (?a, ?b)"]\<close>
setup \<open>Normalizer.add_rewr_normalizer ("rewr_case", (to_meta_eq @{thm case_prod_beta'}))\<close>

(* Let. *)
setup \<open>Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def})\<close>

(* Equivalence relations *)
setup \<open>add_forward_prfstep @{thm Relation.symD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.symI}\<close>
setup \<open>add_forward_prfstep @{thm Relation.transD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.transI}\<close>

(* Options *)
setup \<open>add_resolve_prfstep @{thm option.distinct(1)}\<close>
setup \<open>add_rewrite_rule @{thm Option.option.sel}\<close>
setup \<open>add_forward_prfstep @{thm option.collapse}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm option.simps(1)})\<close>
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Option.option.case}\<close>

end


(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports ZF
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

consts comb :: i
datatype comb =
  K
| S
| app ("p \<in> comb", "q \<in> comb")  (infixl \<open>\<bullet>\<close> 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

consts contract  :: i
abbreviation contract_syntax :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<^sup>1\<close> 50)
  where "p \<rightarrow>\<^sup>1 q \<equiv> <p,q> \<in> contract"

abbreviation contract_multi :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<close> 50)
  where "p \<rightarrow> q \<equiv> <p,q> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<rightarrow>\<^sup>1 p"
    S:   "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<rightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow>\<^sup>1 q\<bullet>r"
    Ap2: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow>\<^sup>1 r\<bullet>q"
  type_intros comb.intros

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

consts parcontract :: i

abbreviation parcontract_syntax :: "[i,i] => o"  (infixl \<open>\<Rrightarrow>\<^sup>1\<close> 50)
  where "p \<Rrightarrow>\<^sup>1 q == <p,q> \<in> parcontract"

abbreviation parcontract_multi :: "[i,i] => o"  (infixl \<open>\<Rrightarrow>\<close> 50)
  where "p \<Rrightarrow> q == <p,q> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "[| p \<in> comb |] ==> p \<Rrightarrow>\<^sup>1 p"
    K:    "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 p"
    S:    "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<Rrightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "[| p\<Rrightarrow>\<^sup>1q;  r\<Rrightarrow>\<^sup>1s |] ==> p\<bullet>r \<Rrightarrow>\<^sup>1 q\<bullet>s"
  type_intros comb.intros

text \<open>
  Misc definitions.
\<close>

definition I :: i
  where "I \<equiv> S\<bullet>K\<bullet>K"

definition diamond :: "i \<Rightarrow> o"
  where "diamond(r) \<equiv>
    \<forall>x y. <x,y>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. <y,z>\<in>r & <y',z> \<in> r))"

subsection \<open>Transitive closure preserves the Church-Rosser property\<close>

lemma diamond_strip_lemmaD [rule_format]:
  "[| diamond(r);  <x,y>:r^+ |] ==>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ & <y,z>: r)"
  apply (unfold diamond_def)
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) ==> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection \<open>Results about Contraction\<close>

text \<open>
  For type checking: replaces \<^term>\<open>a \<rightarrow>\<^sup>1 b\<close> by \<open>a, b \<in>
  comb\<close>.
\<close>

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb ==> I\<bullet>p \<rightarrow> p"
  \<comment> \<open>Example only: not used\<close>
  unfolding I_def by (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  unfolding I_def by blast

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

lemma I_contract_E: "I \<rightarrow>\<^sup>1 r ==> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p \<rightarrow>\<^sup>1 r ==> (\<exists>q. r = K\<bullet>q & p \<rightarrow>\<^sup>1 q)"
  by auto

lemma Ap_reduce1: "[| p \<rightarrow> q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "[| p \<rightarrow> q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text \<open>Counterexample to the diamond property for \<open>\<rightarrow>\<^sup>1\<close>.\<close>

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
  apply (unfold diamond_def)
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection \<open>Results about Parallel Contraction\<close>

text \<open>For type checking: replaces \<open>a \<Rrightarrow>\<^sup>1 b\<close> by \<open>a, b
  \<in> comb\<close>\<close>
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text \<open>Derive a case for each combinator constructor.\<close>
inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]:
    "K\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = K\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = S\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 r ==> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' & p \<Rrightarrow>\<^sup>1 p' & q \<Rrightarrow>\<^sup>1 q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  \<comment> \<open>Church-Rosser property for parallel contraction\<close>
  apply (unfold diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text \<open>
  \medskip Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.
\<close>

lemma contract_imp_parcontract: "p\<rightarrow>\<^sup>1q ==> p\<Rrightarrow>\<^sup>1q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p\<rightarrow>q ==> p\<Rrightarrow>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p\<Rrightarrow>\<^sup>1q ==> p\<rightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p\<Rrightarrow>q ==> p\<rightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p\<Rrightarrow>q \<longleftrightarrow> p\<rightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end