(* Author: Johannes Hölzl, TU München *)

section \<open>Formalization of a Countermeasure by Koepf \& Duermuth 2009\<close>

theory Koepf_Duermuth_Countermeasure
  imports "~~/src/HOL/Probability/Information" "~~/src/HOL/Library/Permutation"
begin

lemma SIGMA_image_vimage:
  "snd ` (SIGMA x:f`X. f -` {x} \<inter> X) = X"
  by (auto simp: image_iff)

declare inj_split_Cons[simp]

definition extensionalD :: "'b \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) set" where
  "extensionalD d A = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = d}"

lemma extensionalD_empty[simp]: "extensionalD d {} = {\<lambda>x. d}"
  unfolding extensionalD_def by (simp add: set_eq_iff fun_eq_iff)

lemma funset_eq_UN_fun_upd_I:
  assumes *: "\<And>f. f \<in> F (insert a A) \<Longrightarrow> f(a := d) \<in> F A"
  and **: "\<And>f. f \<in> F (insert a A) \<Longrightarrow> f a \<in> G (f(a:=d))"
  and ***: "\<And>f x. \<lbrakk> f \<in> F A ; x \<in> G f \<rbrakk> \<Longrightarrow> f(a:=x) \<in> F (insert a A)"
  shows "F (insert a A) = (\<Union>f\<in>F A. fun_upd f a ` (G f))"
proof safe
  fix f assume f: "f \<in> F (insert a A)"
  show "f \<in> (\<Union>f\<in>F A. fun_upd f a ` G f)"
  proof (rule UN_I[of "f(a := d)"])
    show "f(a := d) \<in> F A" using *[OF f] .
    show "f \<in> fun_upd (f(a:=d)) a ` G (f(a:=d))"
    proof (rule image_eqI[of _ _ "f a"])
      show "f a \<in> G (f(a := d))" using **[OF f] .
    qed simp
  qed
next
  fix f x assume "f \<in> F A" "x \<in> G f"
  from ***[OF this] show "f(a := x) \<in> F (insert a A)" .
qed

lemma extensionalD_insert[simp]:
  assumes "a \<notin> A"
  shows "extensionalD d (insert a A) \<inter> (insert a A \<rightarrow> B) = (\<Union>f \<in> extensionalD d A \<inter> (A \<rightarrow> B). (\<lambda>b. f(a := b)) ` B)"
  apply (rule funset_eq_UN_fun_upd_I)
  using assms
  by (auto intro!: inj_onI dest: inj_onD split: if_split_asm simp: extensionalD_def)

lemma finite_extensionalD_funcset[simp, intro]:
  assumes "finite A" "finite B"
  shows "finite (extensionalD d A \<inter> (A \<rightarrow> B))"
  using assms by induct auto

lemma fun_upd_eq_iff: "f(a := b) = g(a := b') \<longleftrightarrow> b = b' \<and> f(a := d) = g(a := d)"
  by (auto simp: fun_eq_iff)

lemma card_funcset:
  assumes "finite A" "finite B"
  shows "card (extensionalD d A \<inter> (A \<rightarrow> B)) = card B ^ card A"
using \<open>finite A\<close> proof induct
  case (insert a A) thus ?case unfolding extensionalD_insert[OF \<open>a \<notin> A\<close>]
  proof (subst card_UN_disjoint, safe, simp_all)
    show "finite (extensionalD d A \<inter> (A \<rightarrow> B))" "\<And>f. finite (fun_upd f a ` B)"
      using \<open>finite B\<close> \<open>finite A\<close> by simp_all
  next
    fix f g b b' assume "f \<noteq> g" and eq: "f(a := b) = g(a := b')" and
      ext: "f \<in> extensionalD d A" "g \<in> extensionalD d A"
    have "f a = d" "g a = d"
      using ext \<open>a \<notin> A\<close> by (auto simp add: extensionalD_def)
    with \<open>f \<noteq> g\<close> eq show False unfolding fun_upd_eq_iff[of _ _ b _ _ d]
      by (auto simp: fun_upd_idem fun_upd_eq_iff)
  next
    { fix f assume "f \<in> extensionalD d A \<inter> (A \<rightarrow> B)"
      have "card (fun_upd f a ` B) = card B"
      proof (auto intro!: card_image inj_onI)
        fix b b' assume "f(a := b) = f(a := b')"
        from fun_upd_eq_iff[THEN iffD1, OF this] show "b = b'" by simp
      qed }
    then show "(\<Sum>i\<in>extensionalD d A \<inter> (A \<rightarrow> B). card (fun_upd i a ` B)) = card B * card B ^ card A"
      using insert by simp
  qed
qed simp

lemma zero_notin_Suc_image[simp]: "0 \<notin> Suc ` A"
  by auto

lemma prod_sum_distrib_lists:
  fixes P and S :: "'a set" and f :: "'a \<Rightarrow> _::semiring_0" assumes "finite S"
  shows "(\<Sum>ms\<in>{ms. set ms \<subseteq> S \<and> length ms = n \<and> (\<forall>i<n. P i (ms!i))}. \<Prod>x<n. f (ms ! x)) =
         (\<Prod>i<n. \<Sum>m\<in>{m\<in>S. P i m}. f m)"
proof (induct n arbitrary: P)
  case 0 then show ?case by (simp cong: conj_cong)
next
  case (Suc n)
  have *: "{ms. set ms \<subseteq> S \<and> length ms = Suc n \<and> (\<forall>i<Suc n. P i (ms ! i))} =
    (\<lambda>(xs, x). x#xs) ` ({ms. set ms \<subseteq> S \<and> length ms = n \<and> (\<forall>i<n. P (Suc i) (ms ! i))} \<times> {m\<in>S. P 0 m})"
    apply (auto simp: image_iff length_Suc_conv)
    apply force+
    apply (case_tac i)
    by force+
  show ?case unfolding *
    using Suc[of "\<lambda>i. P (Suc i)"]
    by (simp add: sum.reindex split_conv sum_cartesian_product'
      lessThan_Suc_eq_insert_0 prod.reindex sum_distrib_right[symmetric] sum_distrib_left[symmetric])
qed

declare space_point_measure[simp]

declare sets_point_measure[simp]

lemma measure_point_measure:
  "finite \<Omega> \<Longrightarrow> A \<subseteq> \<Omega> \<Longrightarrow> (\<And>x. x \<in> \<Omega> \<Longrightarrow> 0 \<le> p x) \<Longrightarrow>
    measure (point_measure \<Omega> (\<lambda>x. ennreal (p x))) A = (\<Sum>i\<in>A. p i)"
  unfolding measure_def
  by (subst emeasure_point_measure_finite) (auto simp: subset_eq sum_nonneg)

locale finite_information =
  fixes \<Omega> :: "'a set"
    and p :: "'a \<Rightarrow> real"
    and b :: real
  assumes finite_space[simp, intro]: "finite \<Omega>"
  and p_sums_1[simp]: "(\<Sum>\<omega>\<in>\<Omega>. p \<omega>) = 1"
  and positive_p[simp, intro]: "\<And>x. 0 \<le> p x"
  and b_gt_1[simp, intro]: "1 < b"

lemma (in finite_information) positive_p_sum[simp]: "0 \<le> sum p X"
   by (auto intro!: sum_nonneg)

sublocale finite_information \<subseteq> prob_space "point_measure \<Omega> p"
  by standard (simp add: one_ereal_def emeasure_point_measure_finite)

sublocale finite_information \<subseteq> information_space "point_measure \<Omega> p" b
  by standard simp

lemma (in finite_information) \<mu>'_eq: "A \<subseteq> \<Omega> \<Longrightarrow> prob A = sum p A"
  by (auto simp: measure_point_measure)

locale koepf_duermuth = K: finite_information keys K b + M: finite_information messages M b
    for b :: real
    and keys :: "'key set" and K :: "'key \<Rightarrow> real"
    and messages :: "'message set" and M :: "'message \<Rightarrow> real" +
  fixes observe :: "'key \<Rightarrow> 'message \<Rightarrow> 'observation"
    and n :: nat
begin

definition msgs :: "('key \<times> 'message list) set" where
  "msgs = keys \<times> {ms. set ms \<subseteq> messages \<and> length ms = n}"

definition P :: "('key \<times> 'message list) \<Rightarrow> real" where
  "P = (\<lambda>(k, ms). K k * (\<Prod>i<n. M (ms ! i)))"

end

sublocale koepf_duermuth \<subseteq> finite_information msgs P b
proof
  show "finite msgs" unfolding msgs_def
    using finite_lists_length_eq[OF M.finite_space, of n]
    by auto

  have [simp]: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A" by (force intro!: inj_onI)

  note sum_distrib_left[symmetric, simp]
  note sum_distrib_right[symmetric, simp]
  note sum_cartesian_product'[simp]

  have "(\<Sum>ms | set ms \<subseteq> messages \<and> length ms = n. \<Prod>x<length ms. M (ms ! x)) = 1"
  proof (induct n)
    case 0 then show ?case by (simp cong: conj_cong)
  next
    case (Suc n)
    then show ?case
      by (simp add: lists_length_Suc_eq lessThan_Suc_eq_insert_0
                    sum.reindex prod.reindex)
  qed
  then show "sum P msgs = 1"
    unfolding msgs_def P_def by simp
  fix x
  have "\<And> A f. 0 \<le> (\<Prod>x\<in>A. M (f x))" by (auto simp: prod_nonneg)
  then show "0 \<le> P x"
    unfolding P_def by (auto split: prod.split simp: zero_le_mult_iff)
qed auto

context koepf_duermuth
begin

definition observations :: "'observation set" where
  "observations = (\<Union>f\<in>observe ` keys. f ` messages)"

lemma finite_observations[simp, intro]: "finite observations"
  unfolding observations_def by auto

definition OB :: "'key \<times> 'message list \<Rightarrow> 'observation list" where
  "OB = (\<lambda>(k, ms). map (observe k) ms)"

definition t :: "'observation list \<Rightarrow> 'observation \<Rightarrow> nat" where
  t_def2: "t seq obs = card { i. i < length seq \<and> seq ! i = obs}"

lemma t_def: "t seq obs = length (filter (op = obs) seq)"
  unfolding t_def2 length_filter_conv_card by (subst eq_commute) simp

lemma card_T_bound: "card ((t\<circ>OB)`msgs) \<le> (n+1)^card observations"
proof -
  have "(t\<circ>OB)`msgs \<subseteq> extensionalD 0 observations \<inter> (observations \<rightarrow> {.. n})"
    unfolding observations_def extensionalD_def OB_def msgs_def
    by (auto simp add: t_def comp_def image_iff subset_eq)
  with finite_extensionalD_funcset
  have "card ((t\<circ>OB)`msgs) \<le> card (extensionalD 0 observations \<inter> (observations \<rightarrow> {.. n}))"
    by (rule card_mono) auto
  also have "\<dots> = (n + 1) ^ card observations"
    by (subst card_funcset) auto
  finally show ?thesis .
qed

abbreviation
 "p A \<equiv> sum P A"

abbreviation
  "\<mu> \<equiv> point_measure msgs P"

abbreviation probability ("\<P>'(_') _") where
  "\<P>(X) x \<equiv> measure \<mu> (X -` x \<inter> msgs)"

abbreviation joint_probability ("\<P>'(_ ; _') _") where
  "\<P>(X ; Y) x \<equiv> \<P>(\<lambda>x. (X x, Y x)) x"

no_notation disj (infixr "|" 30)

abbreviation conditional_probability ("\<P>'(_ | _') _") where
  "\<P>(X | Y) x \<equiv> (\<P>(X ; Y) x) / \<P>(Y) (snd`x)"

notation
  entropy_Pow ("\<H>'( _ ')")

notation
  conditional_entropy_Pow ("\<H>'( _ | _ ')")

notation
  mutual_information_Pow ("\<I>'( _ ; _ ')")

lemma t_eq_imp_bij_func:
  assumes "t xs = t ys"
  shows "\<exists>f. bij_betw f {..<length xs} {..<length ys} \<and> (\<forall>i<length xs. xs ! i = ys ! (f i))"
proof -
  have "count (mset xs) = count (mset ys)"
    using assms by (simp add: fun_eq_iff count_mset t_def)
  then have "xs <~~> ys" unfolding mset_eq_perm count_inject .
  then show ?thesis by (rule permutation_Ex_bij)
qed

lemma \<P>_k: assumes "k \<in> keys" shows "\<P>(fst) {k} = K k"
proof -
  from assms have *:
      "fst -` {k} \<inter> msgs = {k}\<times>{ms. set ms \<subseteq> messages \<and> length ms = n}"
    unfolding msgs_def by auto
  show "(\<P>(fst) {k}) = K k"
    apply (simp add: \<mu>'_eq)
    apply (simp add: * P_def)
    apply (simp add: sum_cartesian_product')
    using prod_sum_distrib_lists[OF M.finite_space, of M n "\<lambda>x x. True"] \<open>k \<in> keys\<close>
    by (auto simp add: sum_distrib_left[symmetric] subset_eq prod.neutral_const)
qed

lemma fst_image_msgs[simp]: "fst`msgs = keys"
proof -
  from M.not_empty obtain m where "m \<in> messages" by auto
  then have *: "{m. set m \<subseteq> messages \<and> length m = n} \<noteq> {}"
    by (auto intro!: exI[of _ "replicate n m"])
  then show ?thesis
    unfolding msgs_def fst_image_times if_not_P[OF *] by simp
qed

lemma sum_distribution_cut:
  "\<P>(X) {x} = (\<Sum>y \<in> Y`space \<mu>. \<P>(X ; Y) {(x, y)})"
  by (subst finite_measure_finite_Union[symmetric])
     (auto simp add: disjoint_family_on_def inj_on_def
           intro!: arg_cong[where f=prob])

lemma prob_conj_imp1:
  "prob ({x. Q x} \<inter> msgs) = 0 \<Longrightarrow> prob ({x. Pr x \<and> Q x} \<inter> msgs) = 0"
  using finite_measure_mono[of "{x. Pr x \<and> Q x} \<inter> msgs" "{x. Q x} \<inter> msgs"]
  using measure_nonneg[of \<mu> "{x. Pr x \<and> Q x} \<inter> msgs"]
  by (simp add: subset_eq)

lemma prob_conj_imp2:
  "prob ({x. Pr x} \<inter> msgs) = 0 \<Longrightarrow> prob ({x. Pr x \<and> Q x} \<inter> msgs) = 0"
  using finite_measure_mono[of "{x. Pr x \<and> Q x} \<inter> msgs" "{x. Pr x} \<inter> msgs"]
  using measure_nonneg[of \<mu> "{x. Pr x \<and> Q x} \<inter> msgs"]
  by (simp add: subset_eq)

lemma simple_function_finite: "simple_function \<mu> f"
  by (simp add: simple_function_def)

lemma entropy_commute: "\<H>(\<lambda>x. (X x, Y x)) = \<H>(\<lambda>x. (Y x, X x))"
  apply (subst (1 2) entropy_simple_distributed[OF simple_distributedI[OF simple_function_finite _ refl]])
  unfolding space_point_measure
proof -
  have eq: "(\<lambda>x. (X x, Y x)) ` msgs = (\<lambda>(x, y). (y, x)) ` (\<lambda>x. (Y x, X x)) ` msgs"
    by auto
  show "- (\<Sum>x\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {x}) * log b (\<P>(X ; Y) {x})) =
    - (\<Sum>x\<in>(\<lambda>x. (Y x, X x)) ` msgs. (\<P>(Y ; X) {x}) * log b (\<P>(Y ; X) {x}))"
    unfolding eq
    apply (subst sum.reindex)
    apply (auto simp: vimage_def inj_on_def intro!: sum.cong arg_cong[where f="\<lambda>x. prob x * log b (prob x)"])
    done
qed simp_all

lemma (in -) measure_eq_0I: "A = {} \<Longrightarrow> measure M A = 0" by simp

lemma conditional_entropy_eq_ce_with_hypothesis:
  "\<H>(X | Y) = -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) *
     log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))"
  apply (subst conditional_entropy_eq[OF
    simple_distributedI[OF simple_function_finite _ refl]
    simple_distributedI[OF simple_function_finite _ refl]])
  unfolding space_point_measure
proof -
  have "- (\<Sum>(x, y)\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))) =
    - (\<Sum>x\<in>X`msgs. (\<Sum>y\<in>Y`msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))))"
    unfolding sum.cartesian_product
    apply (intro arg_cong[where f=uminus] sum.mono_neutral_left)
    apply (auto simp: vimage_def image_iff intro!: measure_eq_0I)
    apply metis
    done
  also have "\<dots> = - (\<Sum>y\<in>Y`msgs. (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))))"
    by (subst sum.commute) rule
  also have "\<dots> = -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) * log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))"
    by (auto simp add: sum_distrib_left vimage_def intro!: sum.cong prob_conj_imp1)
  finally show "- (\<Sum>(x, y)\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))) =
    -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) * log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))" .
qed simp_all

lemma ce_OB_eq_ce_t: "\<I>(fst ; OB) = \<I>(fst ; t\<circ>OB)"
proof -
  txt \<open>Lemma 2\<close>

  { fix k obs obs'
    assume "k \<in> keys" "K k \<noteq> 0" and obs': "obs' \<in> OB ` msgs" and obs: "obs \<in> OB ` msgs"
    assume "t obs = t obs'"
    from t_eq_imp_bij_func[OF this]
    obtain t_f where "bij_betw t_f {..<n} {..<n}" and
      obs_t_f: "\<And>i. i<n \<Longrightarrow> obs!i = obs' ! t_f i"
      using obs obs' unfolding OB_def msgs_def by auto
    then have t_f: "inj_on t_f {..<n}" "{..<n} = t_f`{..<n}" unfolding bij_betw_def by auto

    { fix obs assume "obs \<in> OB`msgs"
      then have **: "\<And>ms. length ms = n \<Longrightarrow> OB (k, ms) = obs \<longleftrightarrow> (\<forall>i<n. observe k (ms!i) = obs ! i)"
        unfolding OB_def msgs_def by (simp add: image_iff list_eq_iff_nth_eq)

      have "(\<P>(OB ; fst) {(obs, k)}) / K k =
          p ({k}\<times>{ms. (k,ms) \<in> msgs \<and> OB (k,ms) = obs}) / K k"
        apply (simp add: \<mu>'_eq) by (auto intro!: arg_cong[where f=p])
      also have "\<dots> =
          (\<Prod>i<n. \<Sum>m\<in>{m\<in>messages. observe k m = obs ! i}. M m)"
        unfolding P_def using \<open>K k \<noteq> 0\<close> \<open>k \<in> keys\<close>
        apply (simp add: sum_cartesian_product' sum_divide_distrib msgs_def ** cong: conj_cong)
        apply (subst prod_sum_distrib_lists[OF M.finite_space]) ..
      finally have "(\<P>(OB ; fst) {(obs, k)}) / K k =
            (\<Prod>i<n. \<Sum>m\<in>{m\<in>messages. observe k m = obs ! i}. M m)" . }
    note * = this

    have "(\<P>(OB ; fst) {(obs, k)}) / K k = (\<P>(OB ; fst) {(obs', k)}) / K k"
      unfolding *[OF obs] *[OF obs']
      using t_f(1) obs_t_f by (subst (2) t_f(2)) (simp add: prod.reindex)
    then have "(\<P>(OB ; fst) {(obs, k)}) = (\<P>(OB ; fst) {(obs', k)})"
      using \<open>K k \<noteq> 0\<close> by auto }
  note t_eq_imp = this

  let ?S = "\<lambda>obs. t -`{t obs} \<inter> OB`msgs"
  { fix k obs assume "k \<in> keys" "K k \<noteq> 0" and obs: "obs \<in> OB`msgs"
    have *: "((\<lambda>x. (t (OB x), fst x)) -` {(t obs, k)} \<inter> msgs) =
      (\<Union>obs'\<in>?S obs. ((\<lambda>x. (OB x, fst x)) -` {(obs', k)} \<inter> msgs))" by auto
    have df: "disjoint_family_on (\<lambda>obs'. (\<lambda>x. (OB x, fst x)) -` {(obs', k)} \<inter> msgs) (?S obs)"
      unfolding disjoint_family_on_def by auto
    have "\<P>(t\<circ>OB ; fst) {(t obs, k)} = (\<Sum>obs'\<in>?S obs. \<P>(OB ; fst) {(obs', k)})"
      unfolding comp_def
      using finite_measure_finite_Union[OF _ _ df]
      by (auto simp add: * intro!: sum_nonneg)
    also have "(\<Sum>obs'\<in>?S obs. \<P>(OB ; fst) {(obs', k)}) = real (card (?S obs)) * \<P>(OB ; fst) {(obs, k)}"
      by (simp add: t_eq_imp[OF \<open>k \<in> keys\<close> \<open>K k \<noteq> 0\<close> obs])
    finally have "\<P>(t\<circ>OB ; fst) {(t obs, k)} = real (card (?S obs)) * \<P>(OB ; fst) {(obs, k)}" .}
  note P_t_eq_P_OB = this

  { fix k obs assume "k \<in> keys" and obs: "obs \<in> OB`msgs"
    have "\<P>(t\<circ>OB | fst) {(t obs, k)} =
      real (card (t -` {t obs} \<inter> OB ` msgs)) * \<P>(OB | fst) {(obs, k)}"
      using \<P>_k[OF \<open>k \<in> keys\<close>] P_t_eq_P_OB[OF \<open>k \<in> keys\<close> _ obs] by auto }
  note CP_t_K = this

  { fix k obs assume "k \<in> keys" and obs: "obs \<in> OB`msgs"
    then have "t -`{t obs} \<inter> OB`msgs \<noteq> {}" (is "?S \<noteq> {}") by auto
    then have "real (card ?S) \<noteq> 0" by auto

    have "\<P>(fst | t\<circ>OB) {(k, t obs)} = \<P>(t\<circ>OB | fst) {(t obs, k)} * \<P>(fst) {k} / \<P>(t\<circ>OB) {t obs}"
      using finite_measure_mono[of "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs" "{x. fst x = k} \<inter> msgs"]
      using measure_nonneg[of \<mu> "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs"]
      by (auto simp add: vimage_def conj_commute subset_eq simp del: measure_nonneg)
    also have "(\<P>(t\<circ>OB) {t obs}) = (\<Sum>k'\<in>keys. (\<P>(t\<circ>OB|fst) {(t obs, k')}) * (\<P>(fst) {k'}))"
      using finite_measure_mono[of "{x. t (OB x) = t obs \<and> fst x = k} \<inter> msgs" "{x. fst x = k} \<inter> msgs"]
      using measure_nonneg[of \<mu> "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs"]
      apply (simp add: sum_distribution_cut[of "t\<circ>OB" "t obs" fst])
      apply (auto intro!: sum.cong simp: subset_eq vimage_def prob_conj_imp1)
      done
    also have "\<P>(t\<circ>OB | fst) {(t obs, k)} * \<P>(fst) {k} / (\<Sum>k'\<in>keys. \<P>(t\<circ>OB|fst) {(t obs, k')} * \<P>(fst) {k'}) =
      \<P>(OB | fst) {(obs, k)} * \<P>(fst) {k} / (\<Sum>k'\<in>keys. \<P>(OB|fst) {(obs, k')} * \<P>(fst) {k'})"
      using CP_t_K[OF \<open>k\<in>keys\<close> obs] CP_t_K[OF _ obs] \<open>real (card ?S) \<noteq> 0\<close>
      by (simp only: sum_distrib_left[symmetric] ac_simps
          mult_divide_mult_cancel_left[OF \<open>real (card ?S) \<noteq> 0\<close>]
        cong: sum.cong)
    also have "(\<Sum>k'\<in>keys. \<P>(OB|fst) {(obs, k')} * \<P>(fst) {k'}) = \<P>(OB) {obs}"
      using sum_distribution_cut[of OB obs fst]
      by (auto intro!: sum.cong simp: prob_conj_imp1 vimage_def)
    also have "\<P>(OB | fst) {(obs, k)} * \<P>(fst) {k} / \<P>(OB) {obs} = \<P>(fst | OB) {(k, obs)}"
      by (auto simp: vimage_def conj_commute prob_conj_imp2)
    finally have "\<P>(fst | t\<circ>OB) {(k, t obs)} = \<P>(fst | OB) {(k, obs)}" . }
  note CP_T_eq_CP_O = this

  let ?H = "\<lambda>obs. (\<Sum>k\<in>keys. \<P>(fst|OB) {(k, obs)} * log b (\<P>(fst|OB) {(k, obs)})) :: real"
  let ?Ht = "\<lambda>obs. (\<Sum>k\<in>keys. \<P>(fst|t\<circ>OB) {(k, obs)} * log b (\<P>(fst|t\<circ>OB) {(k, obs)})) :: real"

  { fix obs assume obs: "obs \<in> OB`msgs"
    have "?H obs = (\<Sum>k\<in>keys. \<P>(fst|t\<circ>OB) {(k, t obs)} * log b (\<P>(fst|t\<circ>OB) {(k, t obs)}))"
      using CP_T_eq_CP_O[OF _ obs]
      by simp
    then have "?H obs = ?Ht (t obs)" . }
  note * = this

  have **: "\<And>x f A. (\<Sum>y\<in>t-`{x}\<inter>A. f y (t y)) = (\<Sum>y\<in>t-`{x}\<inter>A. f y x)" by auto

  { fix x
    have *: "(\<lambda>x. t (OB x)) -` {t (OB x)} \<inter> msgs =
      (\<Union>obs\<in>?S (OB x). OB -` {obs} \<inter> msgs)" by auto
    have df: "disjoint_family_on (\<lambda>obs. OB -` {obs} \<inter> msgs) (?S (OB x))"
      unfolding disjoint_family_on_def by auto
    have "\<P>(t\<circ>OB) {t (OB x)} = (\<Sum>obs\<in>?S (OB x). \<P>(OB) {obs})"
      unfolding comp_def
      using finite_measure_finite_Union[OF _ _ df]
      by (force simp add: * intro!: sum_nonneg) }
  note P_t_sum_P_O = this

  txt \<open>Lemma 3\<close>
  have "\<H>(fst | OB) = -(\<Sum>obs\<in>OB`msgs. \<P>(OB) {obs} * ?Ht (t obs))"
    unfolding conditional_entropy_eq_ce_with_hypothesis using * by simp
  also have "\<dots> = -(\<Sum>obs\<in>t`OB`msgs. \<P>(t\<circ>OB) {obs} * ?Ht obs)"
    apply (subst SIGMA_image_vimage[symmetric, of "OB`msgs" t])
    apply (subst sum.reindex)
    apply (fastforce intro!: inj_onI)
    apply simp
    apply (subst sum.Sigma[symmetric, unfolded split_def])
    using finite_space apply fastforce
    using finite_space apply fastforce
    apply (safe intro!: sum.cong)
    using P_t_sum_P_O
    by (simp add: sum_divide_distrib[symmetric] field_simps **
                  sum_distrib_left[symmetric] sum_distrib_right[symmetric])
  also have "\<dots> = \<H>(fst | t\<circ>OB)"
    unfolding conditional_entropy_eq_ce_with_hypothesis
    by (simp add: comp_def image_image[symmetric])
  finally show ?thesis
    by (subst (1 2) mutual_information_eq_entropy_conditional_entropy) simp_all
qed

theorem "\<I>(fst ; OB) \<le> real (card observations) * log b (real n + 1)"
proof -
  have "\<I>(fst ; OB) = \<H>(fst) - \<H>(fst | t\<circ>OB)"
    unfolding ce_OB_eq_ce_t
    by (rule mutual_information_eq_entropy_conditional_entropy simple_function_finite)+
  also have "\<dots> = \<H>(t\<circ>OB) - \<H>(t\<circ>OB | fst)"
    unfolding entropy_chain_rule[symmetric, OF simple_function_finite simple_function_finite] sign_simps
    by (subst entropy_commute) simp
  also have "\<dots> \<le> \<H>(t\<circ>OB)"
    using conditional_entropy_nonneg[of "t\<circ>OB" fst] by simp
  also have "\<dots> \<le> log b (real (card ((t\<circ>OB)`msgs)))"
    using entropy_le_card[of "t\<circ>OB", OF simple_distributedI[OF simple_function_finite _ refl]] by simp
  also have "\<dots> \<le> log b (real (n + 1)^card observations)"
    using card_T_bound not_empty
    by (auto intro!: log_le simp: card_gt_0_iff of_nat_power [symmetric] simp del: of_nat_power of_nat_Suc)
  also have "\<dots> = real (card observations) * log b (real n + 1)"
    by (simp add: log_nat_power add.commute)
  finally show ?thesis  .
qed

end

end


(*
  File:     Gaussian_Integers_Sums_Of_Two_Squares.thy
  Author:   Manuel Eberl, TU München

  Application of Gaussian integers to determining which natural numbers can be written as a sum
  of two squares
*)
subsection \<open>Sums of two squares\<close>
theory Gaussian_Integers_Sums_Of_Two_Squares
  imports Gaussian_Integers
begin

text \<open>
  As an application, we can now easily prove that a positive natural number is the
  sum of two squares if and only if all prime factors congruent 3 modulo 4 have even
  multiplicity.
\<close>

inductive sum_of_2_squares_nat :: "nat \<Rightarrow> bool" where
  "sum_of_2_squares_nat (a ^ 2 + b ^ 2)"

lemma sum_of_2_squares_nat_altdef: "sum_of_2_squares_nat n \<longleftrightarrow> n \<in> range gauss_int_norm"
proof (safe elim!: sum_of_2_squares_nat.cases)
  fix a b :: nat
  have "a ^ 2 + b ^ 2 = gauss_int_norm (of_nat a + \<i>\<^sub>\<int> * of_nat b)"
    by (auto simp: gauss_int_norm_def nat_add_distrib nat_power_eq)
  thus "a ^ 2 + b ^ 2 \<in> range gauss_int_norm" by blast
next
  fix z :: gauss_int
  have "gauss_int_norm z = nat \<bar>ReZ z\<bar> ^ 2 + nat \<bar>ImZ z\<bar> ^ 2"
    by (auto simp: gauss_int_norm_def nat_add_distrib simp flip: nat_power_eq)
  thus "sum_of_2_squares_nat (gauss_int_norm z)"
    by (auto intro: sum_of_2_squares_nat.intros)
qed

lemma sum_of_2_squares_nat_gauss_int_norm [intro]: "sum_of_2_squares_nat (gauss_int_norm z)"
  by (auto simp: sum_of_2_squares_nat_altdef)

lemma sum_of_2_squares_nat_0 [simp, intro]: "sum_of_2_squares_nat 0"
  and sum_of_2_squares_nat_1 [simp, intro]: "sum_of_2_squares_nat 1"
  and sum_of_2_squares_nat_Suc_0 [simp, intro]: "sum_of_2_squares_nat (Suc 0)"
  and sum_of_2_squares_nat_2 [simp, intro]: "sum_of_2_squares_nat 2"
  using sum_of_2_squares_nat.intros[of 0 0] sum_of_2_squares_nat.intros[of 0 1]
        sum_of_2_squares_nat.intros[of 1 1] by (simp_all add: numeral_2_eq_2)

lemma sum_of_2_squares_nat_mult [intro]:
  assumes "sum_of_2_squares_nat x" "sum_of_2_squares_nat y"
  shows   "sum_of_2_squares_nat (x * y)"
proof -
  from assms obtain z1 z2 where "x = gauss_int_norm z1" "y = gauss_int_norm z2"
    by (auto simp: sum_of_2_squares_nat_altdef)
  hence "x * y = gauss_int_norm (z1 * z2)"
    by (simp add: gauss_int_norm_mult)
  thus ?thesis by auto
qed

lemma sum_of_2_squares_nat_power [intro]:
  assumes "sum_of_2_squares_nat m"
  shows   "sum_of_2_squares_nat (m ^ n)"
  using assms by (induction n) auto

lemma sum_of_2_squares_nat_prod [intro]:
  assumes "\<And>x. x \<in> A \<Longrightarrow> sum_of_2_squares_nat (f x)"
  shows   "sum_of_2_squares_nat (\<Prod>x\<in>A. f x)"
  using assms by (induction A rule: infinite_finite_induct) auto

lemma sum_of_2_squares_nat_prod_mset [intro]:
  assumes "\<And>x. x \<in># A \<Longrightarrow> sum_of_2_squares_nat x"
  shows   "sum_of_2_squares_nat (prod_mset A)"
  using assms by (induction A) auto

lemma sum_of_2_squares_nat_necessary:
  assumes "sum_of_2_squares_nat n" "n > 0"
  assumes "prime p" "[p = 3] (mod 4)"
  shows   "even (multiplicity p n)"
proof -
  define k where "k = multiplicity p n"
  from assms obtain z where z: "gauss_int_norm z = n"
    by (auto simp: sum_of_2_squares_nat_altdef)
  from assms and z have [simp]: "z \<noteq> 0"
    by auto
  have prime': "prime (of_nat p :: gauss_int)"
    using assms prime_gauss_int_of_nat by blast
  have [simp]: "multiplicity (of_nat p) (gauss_cnj z) = multiplicity (of_nat p) z"
    using multiplicity_gauss_cnj[of "of_nat p" z] by simp
  have "multiplicity (of_nat p) (of_nat n :: gauss_int) =
        multiplicity (of_nat p) (z * gauss_cnj z)"
    using z by (simp add: self_mult_gauss_cnj)
  also have "\<dots> = 2 * multiplicity (of_nat p) z"
    using prime' by (subst prime_elem_multiplicity_mult_distrib) auto
  finally have "multiplicity p n = 2 * multiplicity (of_nat p) z"
    by (subst (asm) multiplicity_gauss_int_of_nat)
  thus ?thesis by auto
qed

lemma sum_of_2_squares_nat_sufficient:
  fixes n :: nat
  assumes "n > 0"
  assumes "\<And>p. p \<in> prime_factors n \<Longrightarrow> [p = 3] (mod 4) \<Longrightarrow> even (multiplicity p n)"
  shows "sum_of_2_squares_nat n"
proof -
  define P2 where "P2 = {p\<in>prime_factors n. [p = 1] (mod 4)}"
  define P3 where "P3 = {p\<in>prime_factors n. [p = 3] (mod 4)}"
  from \<open>n > 0\<close> have "n = (\<Prod>p\<in>prime_factors n. p ^ multiplicity p n)"
    by (subst prime_factorization_nat) auto
  also have "\<dots> = (\<Prod>p\<in>{2}\<union>P2\<union>P3. p ^ multiplicity p n)"
    using prime_mod_4_cases
    by (intro prod.mono_neutral_left)
       (auto simp: P2_def P3_def in_prime_factors_iff not_dvd_imp_multiplicity_0)
  also have "\<dots> = (\<Prod>p\<in>{2}\<union>P2. p ^ multiplicity p n) * (\<Prod>p\<in>P3. p ^ multiplicity p n)"
    by (intro prod.union_disjoint) (auto simp: P2_def P3_def cong_def)
  also have "(\<Prod>p\<in>{2}\<union>P2. p ^ multiplicity p n) =
               2 ^ multiplicity 2 n * (\<Prod>p\<in>P2. p ^ multiplicity p n)"
    by (subst prod.union_disjoint) (auto simp: P2_def cong_def)
  also have "(\<Prod>p\<in>P3. p ^ multiplicity p n) = (\<Prod>p\<in>P3. (p ^ 2) ^ (multiplicity p n div 2))"
  proof (intro prod.cong refl)
    fix p :: nat assume p: "p \<in> P3"
    have "(p ^ 2) ^ (multiplicity p n div 2) = p ^ (2 * (multiplicity p n div 2))"
      by (simp add: power_mult)
    also have "even (multiplicity p n)"
      using assms p by (auto simp: P3_def)
    hence "2 * (multiplicity p n div 2) = multiplicity p n"
      by simp
    finally show "p ^ multiplicity p n = (p ^ 2) ^ (multiplicity p n div 2)"
      by simp
  qed
  finally have "n = 2 ^ multiplicity 2 n * (\<Prod>p\<in>P2. p ^ multiplicity p n) *
                      (\<Prod>p\<in>P3. p\<^sup>2 ^ (multiplicity p n div 2))" .

  also have "sum_of_2_squares_nat \<dots>"
  proof (intro sum_of_2_squares_nat_mult sum_of_2_squares_nat_prod; rule sum_of_2_squares_nat_power)
    fix p :: nat assume p: "p \<in> P2"
    with prime_cong_1_mod_4_gauss_int_norm_exists[of p] show "sum_of_2_squares_nat p"
      by (auto simp: P2_def)
  next
    fix p :: nat assume p: "p \<in> P3"
    have "sum_of_2_squares_nat (gauss_int_norm (of_nat p))" ..
    also have "gauss_int_norm (of_nat p) = p ^ 2"
      by simp
    finally show "sum_of_2_squares_nat (p ^ 2)" .
  qed auto
  finally show ?thesis .
qed

theorem sum_of_2_squares_nat_iff:
  "sum_of_2_squares_nat n \<longleftrightarrow>
     n = 0 \<or> (\<forall>p\<in>prime_factors n. [p = 3] (mod 4) \<longrightarrow> even (multiplicity p n))"
  using sum_of_2_squares_nat_necessary[of n] sum_of_2_squares_nat_sufficient[of n] by auto

end


(*  Title:      HOL/Isar_Examples/Fibonacci.thy
    Author:     Gertrud Bauer
    Copyright   1999 Technische Universitaet Muenchen

The Fibonacci function.  Original
tactic script by Lawrence C Paulson.

Fibonacci numbers: proofs of laws taken from

  R. L. Graham, D. E. Knuth, O. Patashnik.
  Concrete Mathematics.
  (Addison-Wesley, 1989)
*)

section \<open>Fib and Gcd commute\<close>

theory Fibonacci
  imports "HOL-Computational_Algebra.Primes"
begin

text_raw \<open>\<^footnote>\<open>Isar version by Gertrud Bauer. Original tactic script by Larry
  Paulson. A few proofs of laws taken from @{cite "Concrete-Math"}.\<close>\<close>

declare One_nat_def [simp]

thm One_nat_def

subsection \<open>Fibonacci numbers\<close>

fun fib :: "nat \<Rightarrow> nat"
  where
    "fib 0 = 0"
  | "fib (Suc 0) = 1"
  | "fib (Suc (Suc x)) = fib x + fib (Suc x)"

text \<open>Alternative induction rule.\<close>

theorem fib_induct: "P 0 \<Longrightarrow> P 1 \<Longrightarrow> (\<And>n. P (n + 1) \<Longrightarrow> P n \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
  for n :: nat
proof (induct n rule: fib.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 x)
  then show ?case by simp
qed

subsection \<open>Fib and gcd commute\<close>

text \<open>A few laws taken from @{cite "Concrete-Math"}.\<close>

lemma fib_add: "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
  (is "?P n")
  \<comment> \<open>see @{cite \<open>page 280\<close> "Concrete-Math"}\<close>
proof (induct n rule: fib.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 x)
  then show ?case
  proof -
    fix x
    assume a1: "fib (x + k + 1) = fib (k + 1) * fib (x + 1) + fib k * fib x"
    assume a2: "fib (Suc x + k + 1) = fib (k + 1) * fib (Suc x + 1) + fib k * fib (Suc x)"
    have "fib (Suc (Suc x) + k + 1) = fib (x + k + 1) + fib (Suc x + k + 1)" by simp
    hence "\<dots> = fib (k + 1) * fib (x + 1)
                + fib k * fib x
                + fib (k + 1) * fib (Suc x + 1)
                + fib k * fib (Suc x)" using a1 a2 by simp
    hence "fib (Suc (Suc x) + k + 1) = fib (k + 1) * (fib (x + 1) + fib (Suc x + 1))
                                     + fib k * (fib x + fib (Suc x))" by (simp add: add_mult_distrib2)
    thus "fib (Suc (Suc x) + k + 1) = fib (k + 1) * fib (Suc (Suc x) + 1)
                                     + fib k * fib (Suc (Suc x))" by simp
  qed
qed

lemma gcd_fib_Suc_eq_1: "gcd (fib n) (fib (n + 1)) = 1"
  (is "?P n")
proof (induct n rule: fib_induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 n)
  assume "gcd (fib (n + 1)) (fib (n + 1 + 1)) = 1"
  assume "gcd (fib n) (fib (n + 1)) = 1"
  have "fib (Suc (Suc n) + 1) = fib (n + 1) + fib (Suc n + 1)" by simp
  also have "\<dots> = fib (Suc n + 1) + fib (n + 1)" by simp
  also have "gcd (fib (Suc n + 1)) \<dots> =
             gcd (fib (Suc n + 1)) (fib (n + 1))" by (rule gcd_add2)
  also have "\<dots> = gcd (fib (n + 1)) (fib (Suc n + 1))" by (simp add: gcd.commute)
  finally have *: "\<dots> = gcd (fib (n + 2)) (fib (n + 2 + 1))" by simp
  thus "gcd (fib (n + 2)) (fib (n + 2 + 1)) = 1" using 3 by simp
qed

lemma gcd_mult_add: "(0::nat) < n \<Longrightarrow> gcd (n * k + m) n = gcd m n"
proof -
  assume "(0::nat) < n"
  hence "gcd (n * k + m) n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat add.commute)
  also from \<open>0 < n\<close> have "\<dots> = gcd m n" by (simp add: gcd_non_0_nat)
  finally show ?thesis .
qed

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  hence "gcd (fib m) (fib (n + m)) = gcd (fib (n + k + 1)) (fib (k + 1))"
    by (simp add: gcd.commute)
  also have "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
    by (rule fib_add)
  also have "gcd \<dots> (fib (k + 1)) = gcd (fib k * fib n) (fib (k + 1))"
    by (simp add: gcd_mult_add)
  also have "\<dots> = gcd (fib n) (fib (k + 1))"
    by (simp only: gcd_fib_Suc_eq_1 gcd_mult_cancel)
  also have "\<dots> = gcd (fib m) (fib n)"
    using Suc by (simp add: gcd.commute)
  finally show ?thesis .
qed

lemma gcd_fib_diff: "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)" if "m \<le> n"
  oops

lemma gcd_fib_mod: "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" if "0 < m"
  oops

theorem fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"
  (is "?P m n")
  oops

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Finding a Suitable Prime\<close>

text \<open>The Berlekamp-Zassenhaus algorithm demands for an input polynomial $f$ to determine
  a prime $p$ such that $f$ is square-free mod $p$ and such that $p$ and the leading coefficient
  of $f$ are coprime. To this end, we first prove that such a prime always exists, provided that
  $f$ is square-free over the integers. Second, we provide a generic algorithm which searches for
  primes have a certain property $P$. Combining both results gives us the suitable prime for
  the Berlekamp-Zassenhaus algorithm.\<close>

theory Suitable_Prime
imports
  Poly_Mod
  Finite_Field_Record_Based
  "HOL-Types_To_Sets.Types_To_Sets"
  Poly_Mod_Finite_Field_Record_Based
  Polynomial_Record_Based
  Square_Free_Int_To_Square_Free_GFp
begin

lemma square_free_separable_GFp: fixes f :: "'a :: prime_card mod_ring poly"
  assumes card: "CARD('a) > degree f"
  and sf: "square_free f"
  shows "separable f"
proof (rule ccontr)
  assume "\<not> separable f"
  with square_free_separable_main[OF sf]
  obtain g k where *: "f = g * k" "degree g \<noteq> 0" and g0: "pderiv g = 0" by auto
  from assms have f: "f \<noteq> 0" unfolding square_free_def by auto
  have "degree f = degree g + degree k" using f unfolding *(1)
    by (subst degree_mult_eq, auto)
  with card have card: "degree g < CARD('a)" by auto
  from *(2) obtain n where deg: "degree g = Suc n" by (cases "degree g", auto)
  from *(2) have cg: "coeff g (degree g) \<noteq> 0" by auto
  from g0 have "coeff (pderiv g) n = 0" by auto
  from this[unfolded coeff_pderiv, folded deg] cg
  have "of_nat (degree g) = (0 :: 'a mod_ring)" by auto
  from of_nat_0_mod_ring_dvd[OF this] have "CARD('a) dvd degree g" .
  with card show False by (simp add: deg nat_dvd_not_less)
qed

lemma square_free_iff_separable_GFp: assumes "degree f < CARD('a)"
  shows "square_free (f :: 'a :: prime_card mod_ring poly) = separable f"
  using separable_imp_square_free[of f] square_free_separable_GFp[OF assms] by auto

definition separable_impl_main :: "int \<Rightarrow> 'i arith_ops_record \<Rightarrow> int poly \<Rightarrow> bool" where
  "separable_impl_main p ff_ops f = separable_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))"

lemma (in prime_field_gen) separable_impl:
  shows "separable_impl_main p ff_ops f \<Longrightarrow> square_free_m f"
  "p > degree_m f \<Longrightarrow> p > separable_bound f \<Longrightarrow> square_free f
   \<Longrightarrow> separable_impl_main p ff_ops f" unfolding separable_impl_main_def
proof -
  define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
  let ?f' = "of_int_poly_i ff_ops (Mp f)"
  define f'' where "f'' \<equiv> of_int_poly (Mp f) :: 'a mod_ring poly"
  have rel_f[transfer_rule]: "poly_rel ?f' f''"
    by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
  have "separable_i ff_ops ?f' \<longleftrightarrow> gcd f'' (pderiv f'') = 1"
    unfolding separable_i_def by transfer_prover
  also have "\<dots> \<longleftrightarrow> coprime f'' (pderiv f'')"
    by (auto simp add: gcd_eq_1_imp_coprime)
  finally have id: "separable_i ff_ops ?f' \<longleftrightarrow> separable f''" unfolding separable_def coprime_iff_coprime .
  have Mprel [transfer_rule]: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
    by (simp add: Mp_f_representative)
  have "square_free f'' = square_free F" unfolding f''_def F by simp
  also have "\<dots> = square_free_m (Mp f)"
    by (transfer, simp)
  also have "\<dots> = square_free_m f" by simp
  finally have id2: "square_free f'' = square_free_m f" .
  from separable_imp_square_free[of f'']
  show "separable_i ff_ops ?f' \<Longrightarrow> square_free_m f"
    unfolding id id2 by auto
  let ?m = "map_poly (of_int :: int \<Rightarrow> 'a mod_ring)"
  let ?f = "?m f"
  assume "p > degree_m f" and bnd: "p > separable_bound f" and sf: "square_free f"
  with rel_funD[OF degree_MP_Rel Mprel, folded p]
  have "p > degree F" by simp
  hence "CARD('a) > degree f''" unfolding f''_def F p by simp
  from square_free_iff_separable_GFp[OF this]
  have "separable_i ff_ops ?f' = square_free f''" unfolding id id2 by simp
  also have "\<dots> = square_free F" unfolding f''_def F by simp
  also have "F = ?f" unfolding F
    by (rule poly_eqI, (subst coeff_map_poly, force)+, unfold Mp_coeff,
    auto simp: M_def, transfer, auto simp: p)
  also have "square_free ?f" using square_free_int_imp_square_free_mod_ring[where 'a = 'a, OF sf] bnd m by auto
  finally
  show "separable_i ff_ops ?f'" .
qed

context poly_mod_prime begin

lemmas separable_impl_integer = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

lemmas separable_impl_uint32 = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

lemmas separable_impl_uint64 = prime_field_gen.separable_impl
  [OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise,cancel_type_definition, OF non_empty]

end

definition separable_impl :: "int \<Rightarrow> int poly \<Rightarrow> bool" where
  "separable_impl p = (
    if p \<le> 65535
    then separable_impl_main p (finite_field_ops32 (uint32_of_int p))
    else if p \<le> 4294967295
    then separable_impl_main p (finite_field_ops64 (uint64_of_int p))
    else separable_impl_main p (finite_field_ops_integer (integer_of_int p)))"

lemma square_free_mod_imp_square_free: assumes
  p: "prime p" and sf: "poly_mod.square_free_m p f"
  and cop: "coprime (lead_coeff f) p"
  shows "square_free f"
proof -
  interpret poly_mod p .
  from sf[unfolded square_free_m_def] have f0: "Mp f \<noteq> 0" and ndvd: "\<And> g. degree_m g > 0 \<Longrightarrow> \<not> (g * g) dvdm f"
    by auto
  from f0 have ff0: "f \<noteq> 0" by auto
  show "square_free f" unfolding square_free_def
  proof (intro conjI[OF ff0] allI impI notI)
    fix g
    assume deg: "degree g > 0" and dvd: "g * g dvd f"
    then obtain h where f: "f = g * g * h" unfolding dvd_def by auto
    from arg_cong[OF this, of Mp] have "(g * g) dvdm f" unfolding dvdm_def by auto
    with ndvd[of g] have deg0: "degree_m g = 0" by auto
    hence g0: "M (lead_coeff g) = 0" unfolding Mp_def using deg
      by (metis M_def deg0 p poly_mod.degree_m_eq prime_gt_1_int neq0_conv)
    from p have p0: "p \<noteq> 0" by auto
    from arg_cong[OF f, of lead_coeff] have "lead_coeff f = lead_coeff g * lead_coeff g * lead_coeff h"
      by (auto simp: lead_coeff_mult)
    hence "lead_coeff g dvd lead_coeff f" by auto
    with cop have cop: "coprime (lead_coeff g) p"
      by (auto elim: coprime_imp_coprime intro: dvd_trans)
    with p0 have "coprime (lead_coeff g mod p) p" by simp
    also have "lead_coeff g mod p = 0"
      using M_def g0 by simp
    finally show False using p
      unfolding prime_int_iff
      by (simp add: prime_int_iff)
  qed
qed

lemma(in poly_mod_prime) separable_impl:
  shows "separable_impl p f \<Longrightarrow> square_free_m f"
    "nat p > degree_m f \<Longrightarrow> nat p > separable_bound f \<Longrightarrow> square_free f
    \<Longrightarrow> separable_impl p f"
  using
    separable_impl_integer[of f]
    separable_impl_uint32[of f]
    separable_impl_uint64[of f]
  unfolding separable_impl_def by (auto split: if_splits)

lemma coprime_lead_coeff_large_prime: assumes prime: "prime (p :: int)"
  and large: "p > abs (lead_coeff f)"
  and f: "f \<noteq> 0"
  shows "coprime (lead_coeff f) p"
proof -
  {
    fix lc
    assume "0 < lc" "lc < p"
    then have "\<not> p dvd lc"
      by (simp add: zdvd_not_zless)
    with \<open>prime p\<close> have "coprime p lc"
      by (auto intro: prime_imp_coprime)
    then have "coprime lc p"
      by (simp add: ac_simps)
  } note main = this
  define lc where "lc = lead_coeff f"
  from f have lc0: "lc \<noteq> 0" unfolding lc_def by auto
  from large have large: "p > abs lc" unfolding lc_def by auto
  have "coprime lc p"
  proof (cases "lc > 0")
    case True
    from large have "p > lc" by auto
    from main[OF True this] show ?thesis .
  next
    case False
    let ?mlc = "- lc"
    from large False lc0 have "?mlc > 0" "p > ?mlc" by auto
    from main[OF this] show ?thesis by simp
  qed
  thus ?thesis unfolding lc_def by auto
qed

lemma prime_for_berlekamp_zassenhaus_exists: assumes sf: "square_free f"
  shows "\<exists> p. prime p \<and> (coprime (lead_coeff f) p \<and> separable_impl p f)"
proof (rule ccontr)
  from assms have f0: "f \<noteq> 0" unfolding square_free_def by auto
  define n where "n = max (max (abs (lead_coeff f)) (degree f)) (separable_bound f)"
  assume contr: "\<not> ?thesis"
  {
    fix p :: int
    assume prime: "prime p" and n: "p > n"
    then interpret poly_mod_prime p by unfold_locales
    from n have large: "p > abs (lead_coeff f)" "nat p > degree f" "nat p > separable_bound f"
      unfolding n_def by auto
    from coprime_lead_coeff_large_prime[OF prime large(1) f0]
    have cop: "coprime (lead_coeff f) p" by auto
    with prime contr have nsf: "\<not> separable_impl p f" by auto
    from large(2) have "nat p > degree_m f" using degree_m_le[of f] by auto
    from separable_impl(2)[OF this large(3) sf] nsf have False by auto
  }
  hence no_large_prime: "\<And> p. prime p \<Longrightarrow> p > n \<Longrightarrow> False" by auto
  from bigger_prime[of "nat n"] obtain p where *: "prime p" "p > nat n" by auto
  define q where "q \<equiv> int p"
  from * have "prime q" "q > n" unfolding q_def by auto
  from no_large_prime[OF this]
  show False .
qed

definition next_primes :: "nat \<Rightarrow> nat \<times> nat list" where
  "next_primes n = (if n = 0 then next_candidates 0 else
    let (m,ps) = next_candidates n in (m,filter prime ps))"

partial_function (tailrec) find_prime_main ::
  "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat" where
  [code]: "find_prime_main f np ps = (case ps of [] \<Rightarrow>
    let (np',ps') = next_primes np
      in find_prime_main f np' ps'
    | (p # ps) \<Rightarrow> if f p then p else find_prime_main f np ps)"

definition find_prime :: "(nat \<Rightarrow> bool) \<Rightarrow> nat" where
  "find_prime f = find_prime_main f 0 []"

lemma find_prime: assumes "\<exists> n. prime n \<and> f n"
  shows "prime (find_prime f) \<and> f (find_prime f)"
proof -
  from assms obtain n where fn: "prime n" "f n" by auto
  {
    fix i ps m
    assume "candidate_invariant i"
      and "n \<in> set ps \<or> n \<ge> i"
      and "m = (Suc n - i, length ps)"
      and "\<And> p. p \<in> set ps \<Longrightarrow> prime p"
    hence "prime (find_prime_main f i ps) \<and> f (find_prime_main f i ps)"
    proof (induct m arbitrary: i ps rule: wf_induct[OF wf_measures[of "[fst, snd]"]])
      case (1 m i ps)
      note IH = 1(1)[rule_format]
      note can = 1(2)
      note n = 1(3)
      note m = 1(4)
      note ps = 1(5)
      note simps [simp] = find_prime_main.simps[of f i ps]
      show ?case
      proof (cases ps)
        case Nil
        with n have i_n: "i \<le> n" by auto
        obtain j qs where np: "next_primes i = (j,qs)" by force
        note j = next_primes[OF np can]
        from j(4) i_n m have meas: "((Suc n - j, length qs), m) \<in> measures [fst, snd]" by auto
        have n: "n \<in> set qs \<or> j \<le> n" unfolding j(5) using i_n fn by auto
        show ?thesis unfolding simps using IH[OF meas j(1) n refl] j(5) by (simp add: Nil np)
      next
        case (Cons p qs)
        show ?thesis
        proof (cases "f p")
          case True
          thus ?thesis unfolding simps using ps unfolding Cons by simp
        next
          case False
          have m: "((Suc n - i, length qs), m) \<in> measures [fst, snd]" using m unfolding Cons by simp
          have n: "n \<in> set qs \<or> i \<le> n" using False n fn by (auto simp: Cons)
          from IH[OF m can n refl ps]
          show ?thesis unfolding simps using Cons False by simp
        qed
      qed
    qed
  } note main = this
  have "candidate_invariant 0" by (simp add: candidate_invariant_def)
  from main[OF this _ refl, of Nil] show ?thesis unfolding find_prime_def by auto
qed

definition suitable_prime_bz :: "int poly \<Rightarrow> int" where
  "suitable_prime_bz f \<equiv> let lc = lead_coeff f in int (find_prime (\<lambda> n. let p = int n in
       coprime lc p \<and> separable_impl p f))"

lemma suitable_prime_bz: assumes sf: "square_free f" and p: "p = suitable_prime_bz f"
  shows "prime p" "coprime (lead_coeff f) p" "poly_mod.square_free_m p f"
proof -
  let ?lc = "lead_coeff f"
  from prime_for_berlekamp_zassenhaus_exists[OF sf, unfolded Let_def]
  obtain P where *: "prime P \<and> coprime ?lc P \<and> separable_impl P f"
    by auto
  hence "prime (nat P)" using prime_int_nat_transfer by blast
  with * have "\<exists> p. prime p \<and> coprime ?lc (int p) \<and> separable_impl p f"
    by (intro exI [of _ "nat P"]) (auto dest: prime_gt_0_int)
  from find_prime[OF this]
  have prime: "prime p" and cop: "coprime ?lc p" and sf: "separable_impl p f"
    unfolding p suitable_prime_bz_def Let_def by auto
  then interpret poly_mod_prime p by unfold_locales
  from prime cop separable_impl(1)[OF sf]
  show "prime p" "coprime ?lc p" "square_free_m f" by auto
qed

definition square_free_heuristic :: "int poly \<Rightarrow> int option" where
  "square_free_heuristic f = (let lc = lead_coeff f in
    find (\<lambda> p. coprime lc p \<and> separable_impl p f) [2, 3, 5, 7, 11, 13, 17, 19, 23])"

lemma find_Some_D: "find f xs = Some y \<Longrightarrow> y \<in> set xs \<and> f y" unfolding find_Some_iff by auto

lemma square_free_heuristic: assumes "square_free_heuristic f = Some p"
  shows "coprime (lead_coeff f) p \<and> separable_impl p f \<and> prime p"
proof -
  from find_Some_D[OF assms[unfolded square_free_heuristic_def Let_def]]
  show ?thesis by auto
qed

end


theory List2
  imports Main
begin

lemma helper1 : "aa = a \<Longrightarrow> \<forall>i . (a # xs) ! i = (aa # ys) ! i \<Longrightarrow> \<forall>i . xs ! i  = ys ! i"
proof -
  assume h1:"aa = a"
    and h2:"\<forall>i . (a # xs) ! i = (aa # ys) ! i"
  show "\<forall>i . xs ! i  = ys ! i"
  proof (rule ccontr)
    {
      assume tmp:"\<exists>i . xs ! i \<noteq> ys ! i"
      {
        fix n
        assume h3:"xs ! n \<noteq> ys ! n"

        from h2 have "(a # xs) ! (Suc n) =  (aa # ys) ! (Suc n)" by (rule allE)
        hence "xs ! n = ys ! n" by simp
        with h3 have False by simp
      }
      with tmp have False by (rule exE)
    }
    thus "\<not> (\<forall>i. xs ! i = ys ! i) \<Longrightarrow> False " by simp
  qed
qed

lemma helper2 : "length xs = length ys \<Longrightarrow> (\<forall>i . xs ! i = ys ! i)  \<Longrightarrow> xs = ys "
proof -
  assume h1:"length xs = length ys"
    and h2:"\<forall>i . xs ! i = ys ! i"
  then show "xs = ys"
  proof (induction xs arbitrary : ys)
    case Nil
    assume "length [] = length ys"
    then show ?case by (cases ys; simp)
  next
    case (Cons a xs)
    assume hyp1:"\<And>ys . length xs = length ys \<Longrightarrow> \<forall>i. xs ! i = ys ! i \<Longrightarrow> xs = ys"
      and hyp2:"\<forall>i. (a # xs) ! i = ys ! i"
      and hyp3:"length (a # xs) = length ys"
    from hyp2 and hyp3 show ?case
    proof (induction ys)
      case Nil
      then show ?case by simp
    next
      case (Cons aa ys)
      assume ha1:"\<forall>i. (a # xs) ! i = ys ! i \<Longrightarrow> length (a # xs) = length ys \<Longrightarrow> a # xs = ys"
        and ha2:" \<forall>i. (a # xs) ! i = (aa # ys) ! i"
        and ha3:"length (a # xs) = length (aa # ys)"
      then show ?case
      proof (cases "aa = a")
        case True
        assume c1:"aa =a"
        from c1 and ha2 have "\<forall>i . xs ! i = ys ! i" by (rule helper1)
        with c1 and hyp1[of ys] ha3 show ?thesis by simp
      next
        case False
        assume c2:"aa \<noteq> a"
        have False using ha2 c2 by (metis nth_Cons_0)
        then show ?thesis by simp
      qed
    qed
  qed
qed

lemma helper3 : "ls = take (length ls div 2) ls @ drop (length ls div 2) ls"
proof (induction ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"ls = take (length ls div 2) ls @ drop (length ls div 2) ls"
  show ?case
  proof (cases ls)
    case Nil
    then show ?thesis by simp
  next
    case (Cons aa list)
    then show ?thesis by simp
  qed
qed

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

lemma lem1: "tailRev xs ys = rev xs @ ys"
proof (induct xs arbitrary : ys)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by simp
qed

theorem "tailRev xs [] = rev xs"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  have "tailRev (a # xs) [] = rev xs  @ [a]" using lem1[of xs "[a]"] by simp
  thus  ?case by simp
qed

primrec reverse_core :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "reverse_core [] res = res"|
  "reverse_core (x#xs) res = reverse_core xs (x#res)"

definition "reverse ls = reverse_core ls []"
  declare reverse_def [simp]
lemma "reverse xs @ ys = reverse_core xs ys "
proof (induction xs arbitrary : ys )
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"\<And>ys .reverse xs @ ys = reverse_core xs ys"
  have "reverse (a#xs) @ ys = reverse_core xs [a] @ ys " by simp
  also have "\<dots> = reverse xs @ [a] @ ys" using hyp[of "[a]"] by simp
  also have "\<dots> = reverse xs @ (a # ys)" by simp
  also have "\<dots> = reverse_core xs (a#ys)" using hyp by simp
  also have "\<dots> = reverse_core (a#xs) ys" by simp
  finally show ?case by simp
qed

lemma helper : "\<forall>ys . reverse xs @ ys = reverse_core xs ys "
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"\<forall>ys. reverse xs @ ys = reverse_core xs ys"
  {
    fix ys
    have tmp1: "reverse xs @ [a] = reverse_core xs [a]" using hyp by simp
    have "( reverse (a # xs) @ ys) = reverse_core xs [a] @ ys " by simp
    also have "\<dots> = reverse xs @ [a] @ ys" using tmp1 by simp
    also have "\<dots> = reverse xs @ (a # ys)" by simp
    also have "\<dots> = reverse_core xs (a#ys)" using hyp by simp
    also have "\<dots> = reverse_core (a#xs) ys" by simp
    finally have "reverse (a # xs) @ ys = reverse_core (a#xs) ys" by assumption
  }
  then show ?case by simp
qed
thm member_rec

theorem "List.member l a  \<Longrightarrow> \<exists> l1 l2. l = l1 @ a # l2"
proof (induction l)
  case Nil
  assume "List.member [] (a::'a)"
  then show ?case by (simp add: member_rec(2))
next
  case (Cons aa l)
  assume hyp1:" List.member l a \<Longrightarrow> \<exists>l1 l2. l = l1 @ a # l2"
     and hyp2:"List.member (aa # l) a"
  from hyp2 have tmp:" (aa = a \<or> List.member l a)" by (simp add : member_rec)
  {
    assume c1:"aa  = a"
    {
      assume "\<not>(\<exists> l1 l2 . aa # l = l1 @ a # l2)"
      hence "\<forall>l1 l2 . aa # l \<noteq> l1 @ a # l2" by simp
      hence "aa # l \<noteq> aa # l" using c1 by auto
      hence False by simp
    }
    hence "\<exists> l1 l2 . aa # l = l1 @ a # l2" by auto
  }
  note f1=this
  {
    assume c1:"List.member l a"
    with hyp1 have tmp2:"\<exists>l1 l2. l = l1 @ a # l2" by simp
    {
      fix l1 l2
      assume c2:"l = l1 @ a # l2"
      {
        assume "\<not>(\<exists>l1 l2. aa # l = l1 @ a # l2 )"
        hence "\<forall>l1 l2. aa # l \<noteq> l1 @ a # l2 " by simp
        hence  "\<forall> l2 . aa # l  \<noteq> ([aa] @ l1) @ a # l2" by (rule allE)
        hence "aa # l \<noteq>  ([aa] @ l1) @ a # l2" by blast
        hence "aa # l1 @ a # l2 \<noteq> ([aa] @ l1) @ a # l2" using c2 by simp
        hence False by simp
      }
      hence "\<exists>l1 l2. aa # l = l1 @ a # l2 " by auto
    }
    with tmp2 have "\<exists>l1 l2. aa # l = l1 @ a # l2 " by auto
  }
  from tmp this and f1 show ?case by auto
qed


theory hw3
imports Main
begin

thm allE

lemma problem1: "(\<forall>x. \<forall>y. P x \<longrightarrow> Q y) \<longrightarrow>( (\<exists>x. P x) \<longrightarrow> (\<forall>y. Q y) )"
  apply (rule impI)
  apply (rule impI)
  apply (rule allI)
  apply (erule exE)
  apply (erule allE)
  apply (erule allE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma problem2: "(\<forall>x. \<forall>y. (P x \<and> P y)) \<longrightarrow> ( (\<forall> x. P x) \<and> (\<forall> y. P y) )"
  apply (rule impI)
  apply (erule allE)
  apply (rule conjI)
   apply (rule allI)
   apply (erule allE)
   apply (erule conjE)
  apply assumption
  apply (rule allI)
  apply (erule allE)
  apply (erule conjE)
  apply assumption
  done


(*  Title:       ConcreteCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Concrete Categories"

text \<open>
  In this section we define a locale \<open>concrete_category\<close>, which provides a uniform
  (and more traditional) way to construct a category from specified sets of objects and arrows,
  with specified identity objects and composition of arrows.
  We prove that the identities and arrows of the constructed category are appropriately
  in bijective correspondence with the given sets and that domains, codomains, and composition
  in the constructed category are as expected according to this correspondence.
  In the later theory \<open>Functor\<close>, once we have defined functors and isomorphisms of categories,
  we will show a stronger property of this construction: if \<open>C\<close> is any category,
  then \<open>C\<close> is isomorphic to the concrete category formed from it in the obvious way by taking
  the identities of \<open>C\<close> as objects, the set of arrows of \<open>C\<close> as arrows, the identities of
  \<open>C\<close> as identity objects, and defining composition of arrows using the composition of \<open>C\<close>.
  Thus no information about \<open>C\<close> is lost by extracting its objects, arrows, identities, and
  composition and rebuilding it as a concrete category.
  We note, however, that we do not assume that the composition function given as parameter
  to the concrete category construction is ``extensional'', so in general it will contain
  incidental information about composition of non-composable arrows, and this information
  is not preserved by the concrete category construction.
\<close>

theory ConcreteCategory
imports Category
begin

  locale concrete_category =
    fixes Obj :: "'o set"
    and Hom :: "'o \<Rightarrow> 'o \<Rightarrow> 'a set"
    and Id :: "'o \<Rightarrow> 'a"
    and Comp :: "'o \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>'a"
    assumes Id_in_Hom: "A \<in> Obj \<Longrightarrow> Id A \<in> Hom A A"
    and Comp_in_Hom: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; f \<in> Hom A B; g \<in> Hom B C \<rbrakk>
                         \<Longrightarrow> Comp C B A g f \<in> Hom A C"
    and Comp_Hom_Id: "\<lbrakk> A \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B A A f (Id A) = f"
    and Comp_Id_Hom: "\<lbrakk> B \<in> Obj; f \<in> Hom A B \<rbrakk> \<Longrightarrow> Comp B B A (Id B) f = f"
    and Comp_assoc: "\<lbrakk> A \<in> Obj; B \<in> Obj; C \<in> Obj; D \<in> Obj;
                       f \<in> Hom A B; g \<in> Hom B C; h \<in> Hom C D \<rbrakk> \<Longrightarrow>
                        Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
  begin

    datatype ('oo, 'aa) arr =
      Null
    | MkArr 'oo 'oo 'aa

    abbreviation MkIde :: "'o \<Rightarrow> ('o, 'a) arr"
    where "MkIde A \<equiv> MkArr A A (Id A)"

    fun Dom :: "('o, 'a) arr \<Rightarrow> 'o"
    where "Dom (MkArr A _ _) = A"
        | "Dom _ = undefined"

    fun Cod
    where "Cod (MkArr _ B _) = B"
        | "Cod _ = undefined"

    fun Map
    where "Map (MkArr _ _ F) = F"
        | "Map _ = undefined"

    abbreviation Arr
    where "Arr f \<equiv> f \<noteq> Null \<and> Dom f \<in> Obj \<and> Cod f \<in> Obj \<and> Map f \<in> Hom (Dom f) (Cod f)"

    abbreviation Ide
    where "Ide a \<equiv> a \<noteq> Null \<and> Dom a \<in> Obj \<and> Cod a = Dom a \<and> Map a = Id (Dom a)"

    (*
     * Here we use COMP in order that uses of this locale can declare themselves as
     * sublocales and then define the abbreviation comp \<equiv> COMP.
     *)
    definition COMP :: "('o, 'a) arr comp"
    where "COMP g f \<equiv> if Arr f \<and> Arr g \<and> Dom g = Cod f then
                         MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                      else
                         Null"

    interpretation partial_magma COMP
      using COMP_def by (unfold_locales, metis)

    lemma null_char:
    shows "null = Null"
    proof -
      let ?P = "\<lambda>n. \<forall>f. COMP n f = n \<and> COMP f n = n"
      have "Null = null"
        using COMP_def null_def the1_equality [of ?P] by metis
      thus ?thesis by simp
    qed

    lemma ide_char:
    shows "ide f \<longleftrightarrow> Ide f"
    proof
      assume f: "Ide f"
      show "ide f"
      proof -
        have "COMP f f \<noteq> null"
          using f COMP_def null_char Id_in_Hom by auto
        moreover have "\<forall>g. (COMP g f \<noteq> null \<longrightarrow> COMP g f = g) \<and>
                           (COMP f g \<noteq> null \<longrightarrow> COMP f g = g)"
        proof (intro allI conjI)
          fix g
          show "COMP g f \<noteq> null \<longrightarrow> COMP g f = g"
            using f COMP_def null_char Comp_Hom_Id Id_in_Hom
            by (cases g, auto)
          show "COMP f g \<noteq> null \<longrightarrow> COMP f g = g"
            using f COMP_def null_char Comp_Id_Hom Id_in_Hom
            by (cases g, auto)
        qed
        ultimately show ?thesis
          using ide_def by blast
      qed
      next
      assume f: "ide f"
      have 1: "Arr f \<and> Dom f = Cod f"
        using f ide_def COMP_def null_char by metis
      moreover have "Map f = Id (Dom f)"
      proof -
        let ?g = "MkIde (Dom f)"
        have g: "Arr f \<and> Arr ?g \<and> Dom ?g = Cod f"
          using 1 Id_in_Hom
          by (intro conjI, simp_all)
        have "COMP ?g f = MkArr (Dom f) (Dom f) (Map f)"
          using g COMP_def Comp_Id_Hom by auto
        moreover have "COMP ?g f = ?g"
        proof -
          have "COMP ?g f \<noteq> null"
            using g 1 COMP_def null_char by simp
          thus ?thesis
            using f ide_def by blast
        qed
        ultimately show ?thesis by simp
      qed
      ultimately show "Ide f" by auto
    qed

    lemma ide_MkIde [simp]:
    assumes "A \<in> Obj"
    shows "ide (MkIde A)"
      using assms ide_char Id_in_Hom by simp

    lemma in_domains_char:
    shows "a \<in> domains f \<longleftrightarrow> Arr f \<and> a = MkIde (Dom f)"
    proof
      assume a: "a \<in> domains f"
      have "Ide a"
        using a domains_def ide_char COMP_def null_char by auto
      moreover have "Arr f \<and> Dom f = Cod a"
      proof -
        have "COMP f a \<noteq> null"
          using a domains_def by simp
        thus ?thesis
          using a domains_def COMP_def [of f a] null_char by metis
      qed
      ultimately show "Arr f \<and> a = MkIde (Dom f)"
        by (cases a, auto)
      next
      assume a: "Arr f \<and> a = MkIde (Dom f)"
      show "a \<in> domains f"
        using a Id_in_Hom COMP_def null_char domains_def by auto
    qed

    lemma in_codomains_char:
    shows "b \<in> codomains f \<longleftrightarrow> Arr f \<and> b = MkIde (Cod f)"
    proof
      assume b: "b \<in> codomains f"
      have "Ide b"
        using b codomains_def ide_char COMP_def null_char by auto
      moreover have "Arr f \<and> Dom b = Cod f"
      proof -
        have "COMP b f \<noteq> null"
          using b codomains_def by simp
        thus ?thesis
          using b codomains_def COMP_def [of b f] null_char by metis
      qed
      ultimately show "Arr f \<and> b = MkIde (Cod f)"
        by (cases b, auto)
      next
      assume b: "Arr f \<and> b = MkIde (Cod f)"
      show "b \<in> codomains f"
        using b Id_in_Hom COMP_def null_char codomains_def by auto
    qed

    lemma arr_char:
    shows "arr f \<longleftrightarrow> Arr f"
      using arr_def in_domains_char in_codomains_char by auto

    lemma arrI:
    assumes "f \<noteq> Null" and "Dom f \<in> Obj" "Cod f \<in> Obj" "Map f \<in> Hom (Dom f) (Cod f)"
    shows "arr f"
      using assms arr_char by blast

    lemma arrE:
    assumes "arr f"
    and "\<lbrakk> f \<noteq> Null; Dom f \<in> Obj; Cod f \<in> Obj; Map f \<in> Hom (Dom f) (Cod f) \<rbrakk> \<Longrightarrow> T"
    shows T
      using assms arr_char by simp

    lemma arr_MkArr [simp]:
    assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
    shows "arr (MkArr A B f)"
      using assms arr_char by simp

    lemma MkArr_Map:
    assumes "arr f"
    shows "MkArr (Dom f) (Cod f) (Map f) = f"
      using assms arr_char by (cases f, auto)

    lemma Arr_comp:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Arr (COMP g f)"
      unfolding COMP_def
      using assms arr_char Comp_in_Hom by simp

    lemma Dom_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Dom (COMP g f) = Dom f"
      unfolding COMP_def
      using assms arr_char by simp

    lemma Cod_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Cod (COMP g f) = Cod g"
      unfolding COMP_def
      using assms arr_char by simp

    lemma Map_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Map (COMP g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
      unfolding COMP_def
      using assms arr_char by simp

    lemma seq_char:
    shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> Dom g = Cod f"
      using arr_char not_arr_null null_char COMP_def Arr_comp by metis

    interpretation category COMP
    proof
      show "\<And>g f. COMP g f \<noteq> null \<Longrightarrow> seq g f"
        using arr_char COMP_def null_char Comp_in_Hom by auto
      show 1: "\<And>f. (domains f \<noteq> {}) = (codomains f \<noteq> {})"
        using in_domains_char in_codomains_char by auto
      show "\<And>f g h. seq h g \<Longrightarrow> seq (COMP h g) f \<Longrightarrow> seq g f"
        by (auto simp add: seq_char)
      show "\<And>f g h. seq h (COMP g f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
        using seq_char COMP_def Comp_in_Hom by (metis Cod_comp)
      show "\<And>f g h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (COMP h g) f"
        using Comp_in_Hom
        by (auto simp add: COMP_def seq_char)
      show "\<And>g f h. seq g f \<Longrightarrow> seq h g \<Longrightarrow> COMP (COMP h g) f = COMP h (COMP g f)"
        using seq_char COMP_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
        by auto
    qed

    proposition is_category:
    shows "category COMP"
      ..

    text \<open>
      Functions \<open>Dom\<close>, \<open>Cod\<close>, and \<open>Map\<close> establish a correspondence between the
      arrows of the constructed category and the elements of the originally given
      parameters \<open>Obj\<close> and \<open>Hom\<close>.
    \<close>

    lemma Dom_in_Obj:
    assumes "arr f"
    shows "Dom f \<in> Obj"
      using assms arr_char by simp

    lemma Cod_in_Obj:
    assumes "arr f"
    shows "Cod f \<in> Obj"
      using assms arr_char by simp

    lemma Map_in_Hom:
    assumes "arr f"
    shows "Map f \<in> Hom (Dom f) (Cod f)"
      using assms arr_char by simp

    lemma MkArr_in_hom:
    assumes "A \<in> Obj" and "B \<in> Obj" and "f \<in> Hom A B"
    shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
      using assms arr_char ide_MkIde
      by (simp add: in_codomains_char in_domains_char in_hom_def)

    text \<open>
      The next few results show that domains, codomains, and composition in the constructed
      category are as expected according to the just-given correspondence.
    \<close>

    lemma cod_char:
    shows "cod f = (if arr f then MkIde (Cod f) else null)"
      using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto

    lemma comp_char:
    shows "COMP g f = (if seq g f then
                         MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                       else
                         null)"
      using COMP_def seq_char arr_char null_char by auto

    lemma in_hom_char:
    shows "in_hom f a b \<longleftrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
    proof
      show "in_hom f a b \<Longrightarrow> arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b"
        using arr_char dom_char cod_char by auto
      show "arr f \<and> ide a \<and> ide b \<and> Dom f = Dom a \<and> Cod f = Dom b \<Longrightarrow> in_hom f a b"
        using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
    qed

    lemma Dom_dom [simp]:
    assumes "arr f"
    shows "Dom (dom f) = Dom f"
      using assms MkArr_Map dom_char by simp

    lemma Cod_dom [simp]:
    assumes "arr f"
    shows "Cod (dom f) = Dom f"
      using assms MkArr_Map dom_char by simp

    lemma Dom_cod [simp]:
    assumes "arr f"
    shows "Dom (cod f) = Cod f"
      using assms MkArr_Map cod_char by simp

    lemma Cod_cod [simp]:
    assumes "arr f"
    shows "Cod (cod f) = Cod f"
      using assms MkArr_Map cod_char by simp

    lemma Map_dom [simp]:
    assumes "arr f"
    shows "Map (dom f) = Id (Dom f)"
      using assms MkArr_Map dom_char by simp

    lemma Map_cod [simp]:
    assumes "arr f"
    shows "Map (cod f) = Id (Cod f)"
      using assms MkArr_Map cod_char by simp

    lemma Map_ide:
    assumes "ide a"
    shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
      using assms ide_char dom_char [of a] Map_dom Map_cod ideD(1) by metis+

    (*
     * TODO: The next two ought to be simps, but they cause looping when they find themselves
     * in combination with dom_char and cod_char.
     *)
    lemma MkIde_Dom:
    assumes "arr a"
    shows "MkIde (Dom a) = dom a"
      using assms arr_char dom_char by (cases a, auto)

    lemma MkIde_Cod:
    assumes "arr a"
    shows "MkIde (Cod a) = cod a"
      using assms arr_char cod_char by (cases a, auto)

    lemma MkIde_Dom' [simp]:
    assumes "ide a"
    shows "MkIde (Dom a) = a"
      using assms MkIde_Dom by simp

    lemma MkIde_Cod' [simp]:
    assumes "ide a"
    shows "MkIde (Cod a) = a"
      using assms MkIde_Cod by simp

    lemma dom_MkArr [simp]:
    assumes "arr (MkArr A B F)"
    shows "dom (MkArr A B F) = MkIde A"
      using assms dom_char by simp

    lemma cod_MkArr [simp]:
    assumes "arr (MkArr A B F)"
    shows "cod (MkArr A B F) = MkIde B"
      using assms cod_char by simp

    lemma comp_MkArr [simp]:
    assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
    shows "COMP (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
      using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp

    text \<open>
      The set \<open>Obj\<close> of ``objects'' given as a parameter is in bijective correspondence
      (via function \<open>MkIde\<close>) with the set of identities of the resulting category.
    \<close>

    proposition bij_betw_ide_Obj:
    shows "MkIde \<in> Obj \<rightarrow> Collect ide"
    and "Dom \<in> Collect ide \<rightarrow> Obj"
    and "A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
    and "a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
    and "bij_betw Dom (Collect ide) Obj"
    proof -
      show "MkIde \<in> Obj \<rightarrow> Collect ide"
        using ide_MkIde by simp
      moreover show "Dom \<in> Collect ide \<rightarrow> Obj"
        using arr_char ideD(1) by simp
      moreover show "\<And>A. A \<in> Obj \<Longrightarrow> Dom (MkIde A) = A"
        by simp
      moreover show "\<And>a. a \<in> Collect ide \<Longrightarrow> MkIde (Dom a) = a"
        using MkIde_Dom by simp
      ultimately show "bij_betw Dom (Collect ide) Obj"
        using bij_betwI by blast
    qed

    text \<open>
      For each pair of identities \<open>a\<close> and \<open>b\<close>, the set \<open>Hom (Dom a) (Dom b)\<close> is in
      bijective correspondence (via function \<open>MkArr (Dom a) (Dom b)\<close>) with the
      ``hom-set'' \<open>hom a b\<close> of the resulting category.
    \<close>

    proposition bij_betw_hom_Hom:
    assumes "ide a" and "ide b"
    shows "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
    and "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
    and "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
    and "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
    and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
    proof -
      show "Map \<in> hom a b \<rightarrow> Hom (Dom a) (Dom b)"
        using Map_in_Hom cod_char dom_char in_hom_char by fastforce
      moreover show "MkArr (Dom a) (Dom b) \<in> Hom (Dom a) (Dom b) \<rightarrow> hom a b"
        using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
      moreover show "\<And>f. f \<in> hom a b \<Longrightarrow> MkArr (Dom a) (Dom b) (Map f) = f"
        using MkArr_Map by auto
      moreover show "\<And>F. F \<in> Hom (Dom a) (Dom b) \<Longrightarrow> Map (MkArr (Dom a) (Dom b) F) = F"
        by simp
      ultimately show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
        using bij_betwI by blast
    qed

    lemma arr_eqI:
    assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
    shows "t = t'"
      using assms MkArr_Map by metis

  end

  sublocale concrete_category \<subseteq> category COMP
    using is_category by auto

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

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = (if x z z2 then True else elem z xs)"

theorem property0 :
  "elem z (y xs (cons2 z (nil2)))"
  (*Why induct on xs?
  Because y is the innermost recursive constant,
  with case distinction on the first parameter.*)
  (*"arbitrary:z" also works well.*)
  (*Why "arbitrary:z"?
  Because z appears within "(cons2 z (nil2))", which is the second
  argument of the innermost recursive constant, "y", and we apply
  mathematical induction on the first argument of this function(?) *)
  apply(induct xs (*arbitrary: z*))
   apply clarsimp
   apply(induct_tac z)
  by auto

end


(*  Title:      HOL/Algebra/RingHom.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory RingHom
imports Ideal
begin

section \<open>Homomorphisms of Non-Commutative Rings\<close>

text \<open>Lifting existing lemmas in a \<open>ring_hom_ring\<close> locale\<close>
locale ring_hom_ring = R?: ring R + S?: ring S
    for R (structure) and S (structure) +
  fixes h
  assumes homh: "h \<in> ring_hom R S"
  notes hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

sublocale ring_hom_cring \<subseteq> ring: ring_hom_ring
  by standard (rule homh)

sublocale ring_hom_ring \<subseteq> abelian_group?: abelian_group_hom R S
apply (rule abelian_group_homI)
  apply (rule R.is_abelian_group)
 apply (rule S.is_abelian_group)
apply (intro group_hom.intro group_hom_axioms.intro)
  apply (rule R.a_group)
 apply (rule S.a_group)
apply (insert homh, unfold hom_def ring_hom_def)
apply simp
done

lemma (in ring_hom_ring) is_ring_hom_ring:
  "ring_hom_ring R S h"
  by (rule ring_hom_ring_axioms)

lemma ring_hom_ringI:
  fixes R (structure) and S (structure)
  assumes "ring R" "ring S"
  assumes (* morphism: "h \<in> carrier R \<rightarrow> carrier S" *)
          hom_closed: "!!x. x \<in> carrier R ==> h x \<in> carrier S"
      and compatible_mult: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_add: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret ring R by fact
  interpret ring S by fact
  show ?thesis apply unfold_locales
apply (unfold ring_hom_def, safe)
   apply (simp add: hom_closed Pi_def)
  apply (erule (1) compatible_mult)
 apply (erule (1) compatible_add)
apply (rule compatible_one)
done
qed

lemma ring_hom_ringI2:
  assumes "ring R" "ring S"
  assumes h: "h \<in> ring_hom R S"
  shows "ring_hom_ring R S h"
proof -
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro)
    apply (rule R.ring_axioms)
    apply (rule S.ring_axioms)
    apply (rule h)
    done
qed

lemma ring_hom_ringI3:
  fixes R (structure) and S (structure)
  assumes "abelian_group_hom R S h" "ring R" "ring S"
  assumes compatible_mult: "\<And>x y. [| x \<in> carrier R; y \<in> carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret abelian_group_hom R S h by fact
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro, rule R.ring_axioms, rule S.ring_axioms)
    apply (insert group_hom.homh[OF a_group_hom])
    apply (unfold hom_def ring_hom_def, simp)
    apply safe
    apply (erule (1) compatible_mult)
    apply (rule compatible_one)
    done
qed

lemma ring_hom_cringI:
  assumes "ring_hom_ring R S h" "cring R" "cring S"
  shows "ring_hom_cring R S h"
proof -
  interpret ring_hom_ring R S h by fact
  interpret R: cring R by fact
  interpret S: cring S by fact
  show ?thesis by (intro ring_hom_cring.intro ring_hom_cring_axioms.intro)
    (rule R.is_cring, rule S.is_cring, rule homh)
qed

subsection \<open>The Kernel of a Ring Homomorphism\<close>

\<comment> \<open>the kernel of a ring homomorphism is an ideal\<close>
lemma (in ring_hom_ring) kernel_is_ideal:
  shows "ideal (a_kernel R S h) R"
apply (rule idealI)
   apply (rule R.ring_axioms)
  apply (rule additive_subgroup.a_subgroup[OF additive_subgroup_a_kernel])
 apply (unfold a_kernel_def', simp+)
done

text \<open>Elements of the kernel are mapped to zero\<close>
lemma (in abelian_group_hom) kernel_zero [simp]:
  "i \<in> a_kernel R S h \<Longrightarrow> h i = \<zero>\<^bsub>S\<^esub>"
by (simp add: a_kernel_defs)

subsection \<open>Cosets\<close>

text \<open>Cosets of the kernel correspond to the elements of the image of the homomorphism\<close>
lemma (in ring_hom_ring) rcos_imp_homeq:
  assumes acarr: "a \<in> carrier R"
      and xrcos: "x \<in> a_kernel R S h +> a"
  shows "h x = h a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  from xrcos
      have "\<exists>i \<in> a_kernel R S h. x = i \<oplus> a" by (simp add: a_r_coset_defs)
  from this obtain i
      where iker: "i \<in> a_kernel R S h"
        and x: "x = i \<oplus> a"
      by fast+
  note carr = acarr iker[THEN a_Hcarr]

  from x
      have "h x = h (i \<oplus> a)" by simp
  also from carr
      have "\<dots> = h i \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from iker
      have "\<dots> = \<zero>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from carr
      have "\<dots> = h a" by simp
  finally
      show "h x = h a" .
qed

lemma (in ring_hom_ring) homeq_imp_rcos:
  assumes acarr: "a \<in> carrier R"
      and xcarr: "x \<in> carrier R"
      and hx: "h x = h a"
  shows "x \<in> a_kernel R S h +> a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  note carr = acarr xcarr
  note hcarr = acarr[THEN hom_closed] xcarr[THEN hom_closed]

  from hx and hcarr
      have a: "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = \<zero>\<^bsub>S\<^esub>" by algebra
  from carr
      have "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = h (x \<oplus> \<ominus>a)" by simp
  from a and this
      have b: "h (x \<oplus> \<ominus>a) = \<zero>\<^bsub>S\<^esub>" by simp

  from carr have "x \<oplus> \<ominus>a \<in> carrier R" by simp
  from this and b
      have "x \<oplus> \<ominus>a \<in> a_kernel R S h"
      unfolding a_kernel_def'
      by fast

  from this and carr
      show "x \<in> a_kernel R S h +> a" by (simp add: a_rcos_module_rev)
qed

corollary (in ring_hom_ring) rcos_eq_homeq:
  assumes acarr: "a \<in> carrier R"
  shows "(a_kernel R S h) +> a = {x \<in> carrier R. h x = h a}"
apply rule defer 1
apply clarsimp defer 1
proof
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xrcos: "x \<in> a_kernel R S h +> a"
  from acarr and this
      have xcarr: "x \<in> carrier R"
      by (rule a_elemrcos_carrier)

  from xrcos
      have "h x = h a" by (rule rcos_imp_homeq[OF acarr])
  from xcarr and this
      show "x \<in> {x \<in> carrier R. h x = h a}" by fast
next
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xcarr: "x \<in> carrier R"
     and hx: "h x = h a"
  from acarr xcarr hx
      show "x \<in> a_kernel R S h +> a" by (rule homeq_imp_rcos)
qed

(* NEW ========================================================================= *)
lemma (in ring_hom_ring) nat_pow_hom:
  "x \<in> carrier R \<Longrightarrow> h (x [^] (n :: nat)) = (h x) [^]\<^bsub>S\<^esub> n"
  by (induct n) (auto)
(* ============================================================================= *)

(* REPLACED ==================================================================== *)
lemma (in ring_hom_ring) hom_finsum [simp]:
  "f \<in> A \<rightarrow> carrier R \<Longrightarrow>
  h (finsum R f A) = finsum S (h \<circ> f) A"
  by (induct A rule: infinite_finite_induct, auto simp: Pi_def)
(* ============================================================================= *)

(*contributed by Paulo Emílio de Vilhena*)
lemma (in ring_hom_ring) inj_on_domain:
  assumes "inj_on h (carrier R)"
  shows "domain S \<Longrightarrow> domain R"
proof -
  assume A: "domain S" show "domain R"
  proof
    have "h \<one> = \<one>\<^bsub>S\<^esub> \<and> h \<zero> = \<zero>\<^bsub>S\<^esub>" by simp
    hence "h \<one> \<noteq> h \<zero>"
      using domain.one_not_zero[OF A] by simp
    thus "\<one> \<noteq> \<zero>"
      using assms unfolding inj_on_def by fastforce
  next
    fix a b
    assume a: "a \<in> carrier R"
       and b: "b \<in> carrier R"
    have "h (a \<otimes> b) = (h a) \<otimes>\<^bsub>S\<^esub> (h b)" by (simp add: a b)
    also have " ... = (h b) \<otimes>\<^bsub>S\<^esub> (h a)" using a b A cringE(1)[of S]
      by (simp add: cring.cring_simprules(14) domain_def)
    also have " ... = h (b \<otimes> a)" by (simp add: a b)
    finally have "h (a \<otimes> b) = h (b \<otimes> a)" .
    thus "a \<otimes> b = b \<otimes> a"
      using assms a b unfolding inj_on_def by simp

    assume  ab: "a \<otimes> b = \<zero>"
    hence "h (a \<otimes> b) = \<zero>\<^bsub>S\<^esub>" by simp
    hence "(h a) \<otimes>\<^bsub>S\<^esub> (h b) = \<zero>\<^bsub>S\<^esub>" using a b by simp
    hence "h a =  \<zero>\<^bsub>S\<^esub> \<or> h b =  \<zero>\<^bsub>S\<^esub>" using a b domain.integral[OF A] by simp
    thus "a = \<zero> \<or> b = \<zero>"
      using a b assms unfolding inj_on_def by force
  qed
qed

end