(* Title: BIBD
   Author: Chelsea Edmonds
*)

theory BIBD imports Block_Designs
begin

section \<open>BIBD's\<close>
text \<open>BIBD's are perhaps the most commonly studied type of design in combinatorial design theory,
and usually the first type of design explored in a design theory course.
These designs are a type of t-design, where $t = 2$\<close>

subsection \<open>BIBD Basics\<close>
locale bibd = t_design \<V> \<B> \<k> 2 \<Lambda>
  for point_set ("\<V>") and block_collection ("\<B>")
    and u_block_size ("\<k>") and index ("\<Lambda>")

begin

lemma min_block_size_2: "\<k> \<ge> 2"
  using block_size_t by simp

lemma points_index_pair: "y \<in> \<V> \<Longrightarrow> x \<in> \<V> \<Longrightarrow> x \<noteq> y \<Longrightarrow>  size ({# bl \<in># \<B> . {x, y} \<subseteq> bl#}) = \<Lambda>"
  using balanced card_2_iff empty_subsetI insert_subset points_index_def by metis

lemma index_one_empty_rm_blv [simp]:
  assumes "\<Lambda> = 1" and " blv \<in># \<B>" and "p \<subseteq> blv" and "card p = 2"
  shows "{#bl \<in># remove1_mset blv \<B> . p \<subseteq> bl#} = {#}"
proof -
  have blv_in: "blv \<in># filter_mset ((\<subseteq>) p) \<B>"
    using assms by simp
  have "p \<subseteq> \<V>" using assms wellformed by auto
  then have "size (filter_mset ((\<subseteq>) p) \<B>) = 1"
    using balanced assms by (simp add: points_index_def)
  then show ?thesis using blv_in filter_diff_mset filter_single_mset
    by (metis (no_types, lifting) add_mset_eq_single assms(3) insert_DiffM size_1_singleton_mset)
qed

lemma index_one_alt_bl_not_exist:
  assumes "\<Lambda> = 1" and " blv \<in># \<B>" and "p \<subseteq> blv" and "card p = 2"
  shows" \<And> bl. bl \<in># remove1_mset blv \<B> \<Longrightarrow> \<not> (p \<subseteq> bl) "
  using index_one_empty_rm_blv
  by (metis assms(1) assms(2) assms(3) assms(4) filter_mset_empty_conv)

subsection \<open>Necessary Conditions for Existence\<close>

text \<open>The necessary conditions on the existence of a $(v, k, \lambda)$-bibd are one of the
fundamental first theorems on designs. Proofs based off MATH3301 lecture notes \<^cite>\<open>"HerkeLectureNotes2016"\<close>
 and Stinson \<^cite>\<open>"stinsonCombinatorialDesignsConstructions2004"\<close>\<close>

lemma necess_cond_1_rhs:
  assumes "x \<in> \<V>"
  shows "size ({# p \<in># (mset_set (\<V> - {x}) \<times># {# bl \<in># \<B> . x \<in> bl #}). fst p \<in> snd p#}) = \<Lambda> * (\<v>- 1)"
proof -
  let ?M = "mset_set (\<V> - {x})"
  let ?B = "{# bl \<in># \<B> . x \<in> bl #}"
  have m_distinct: "distinct_mset ?M" using assms mset_points_distinct_diff_one by simp
  have y_point: "\<And> y . y \<in># ?M \<Longrightarrow> y \<in> \<V>" using assms
    by (simp add: finite_sets)
  have b_contents: "\<And> bl. bl \<in># ?B \<Longrightarrow> x \<in> bl" using assms by auto
  have "\<And> y. y \<in># ?M \<Longrightarrow> y \<noteq> x" using assms
    by (simp add: finite_sets)
  then have "\<And> y .y \<in># ?M \<Longrightarrow> size ({# bl \<in># ?B . {x, y} \<subseteq> bl#}) = \<Lambda>"
    using points_index_pair filter_filter_mset_ss_member y_point assms finite_sets
    by metis
  then have  "\<And> y .y \<in># ?M \<Longrightarrow> size ({# bl \<in># ?B . x \<in> bl \<and> y \<in> bl#}) = \<Lambda>"
    by auto
  then have bl_set_size: "\<And> y . y \<in># ?M \<Longrightarrow> size ({# bl \<in># ?B .  y \<in> bl#}) = \<Lambda>"
    using b_contents by (metis (no_types, lifting) filter_mset_cong)
  then have final_size: "size (\<Sum>p\<in>#?M . ({#p#} \<times># {#bl \<in># ?B. p \<in> bl#})) = size (?M) * \<Lambda>"
    using m_distinct size_Union_distinct_cart_prod_filter bl_set_size by blast
  have "size ?M = \<v> - 1" using v_non_zero
    by (simp add: assms(1) finite_sets)
  thus ?thesis using final_size
    by (simp add: set_break_down_left)
qed

lemma necess_cond_1_lhs:
  assumes "x \<in> \<V>"
  shows "size ({# p \<in># (mset_set (\<V> - {x}) \<times># {# bl \<in># \<B> . x \<in> bl #}). fst p \<in> snd p#})
      = (\<B> rep x) * (\<k> - 1)"
    (is "size ({# p \<in># (?M \<times># ?B). fst p \<in> snd p#}) = (\<B> rep x) * (\<k> - 1) ")
proof -
  have "\<And> y. y \<in># ?M \<Longrightarrow> y \<noteq> x" using assms
    by (simp add: finite_sets)
  have distinct_m: "distinct_mset ?M" using assms mset_points_distinct_diff_one by simp
  have finite_M: "finite (\<V> - {x})" using finite_sets by auto
  have block_choices: "size ?B = \<B> rep x"
    by (simp add: assms(1) point_replication_number_def)
  have bl_size: "\<forall> bl \<in># ?B. card {p \<in> \<V> . p \<in> bl } = \<k> " using uniform_unfold_point_set by simp
  have x_in_set: "\<forall> bl \<in># ?B . {x} \<subseteq> {p \<in> \<V>. p \<in> bl}" using assms by auto
  then have "\<forall> bl \<in># ?B. card {p \<in> (\<V> - {x}) . p \<in> bl } = card ({p \<in> \<V> . p \<in> bl } - {x})"
    by (simp add: set_filter_diff_card)
  then have "\<forall> bl \<in># ?B. card {p \<in> (\<V> - {x}) . p \<in> bl } = \<k> - 1"
    using bl_size x_in_set card_Diff_subset finite_sets k_non_zero by auto
  then have "\<And> bl . bl \<in># ?B \<Longrightarrow> size {#p \<in># ?M . p \<in> bl#} = \<k> - 1"
    using assms finite_M card_size_filter_eq by auto
  then have "size (\<Sum>bl\<in>#?B. ( {# p \<in># ?M . p \<in> bl #} \<times># {#bl#})) = size (?B) * (\<k> - 1)"
    using distinct_m size_Union_distinct_cart_prod_filter2 by blast
  thus ?thesis using block_choices k_non_zero by (simp add: set_break_down_right)
qed

lemma r_constant: "x \<in> \<V> \<Longrightarrow> (\<B> rep x) * (\<k> -1) = \<Lambda> * (\<v> - 1)"
  using necess_cond_1_rhs necess_cond_1_lhs design_points_nempty by force

lemma replication_number_value:
  assumes "x \<in> \<V>"
  shows "(\<B> rep x) = \<Lambda> * (\<v> - 1) div (\<k> - 1)"
  using min_block_size_2 r_constant assms
  by (metis diff_is_0_eq diffs0_imp_equal div_by_1 k_non_zero nonzero_mult_div_cancel_right
      one_div_two_eq_zero one_le_numeral zero_neq_one)

lemma r_constant_alt: "\<forall> x \<in> \<V>. \<B> rep x = \<Lambda> * (\<v> - 1) div (\<k> - 1)"
  using r_constant replication_number_value by blast

end

text \<open>Using the first necessary condition, it is possible to show that a bibd has
a constant replication number\<close>

sublocale bibd \<subseteq> constant_rep_design \<V> \<B>  "(\<Lambda> * (\<v> - 1) div (\<k> - 1))"
  using r_constant_alt by (unfold_locales) simp_all

lemma (in t_design) bibdI [intro]: "\<t> = 2 \<Longrightarrow> bibd \<V> \<B> \<k> \<Lambda>\<^sub>t"
  using t_lt_order block_size_t by (unfold_locales) (simp_all)

context bibd
begin

abbreviation "\<r> \<equiv> (\<Lambda> * (\<v> - 1) div (\<k> - 1))"

lemma necessary_condition_one:
  shows "\<r> * (\<k> - 1) = \<Lambda> * (\<v> - 1)"
  using necess_cond_1_rhs necess_cond_1_lhs design_points_nempty rep_number by auto

lemma bibd_point_occ_rep:
  assumes "x \<in> bl"
  assumes "bl \<in># \<B>"
  shows  "(\<B> - {#bl#}) rep x = \<r> - 1"
proof -
  have xin: "x \<in> \<V>" using assms wf_invalid_point by blast
  then have rep: "size {# blk \<in># \<B>. x \<in> blk #} = \<r>" using rep_number_unfold_set by simp
  have "(\<B> - {#bl#}) rep x = size {# blk \<in># (\<B> - {#bl#}). x \<in> blk #}"
    by (simp add: point_replication_number_def)
  then have "(\<B> - {#bl#}) rep x = size {# blk \<in># \<B>. x \<in> blk #} - 1"
    by (simp add: assms size_Diff_singleton)
  then show ?thesis using assms rep r_gzero by simp
qed

lemma necess_cond_2_lhs: "size {# x \<in># (mset_set \<V> \<times># \<B>) . (fst x) \<in> (snd x)  #} = \<v> * \<r>"
proof -
  let ?M = "mset_set \<V>"
  have "\<And> p . p \<in># ?M \<Longrightarrow> size ({# bl \<in># \<B> . p \<in> bl #}) = \<r>"
    using finite_sets rep_number_unfold_set r_gzero nat_eq_iff2 by auto
  then have "size (\<Sum>p\<in>#?M. ({#p#} \<times># {#bl \<in># \<B>. p \<in> bl#})) = size ?M * (\<r>)"
    using mset_points_distinct size_Union_distinct_cart_prod_filter by blast
  thus ?thesis using r_gzero
    by (simp add: set_break_down_left)
qed

lemma necess_cond_2_rhs: "size {# x \<in># (mset_set \<V> \<times># \<B>) . (fst x) \<in> (snd x)  #} = \<b>*\<k>"
  (is "size {# x \<in># (?M \<times># ?B). (fst x) \<in> (snd x)  #} = \<b>*\<k>")
proof -
  have "\<And> bl . bl \<in># ?B \<Longrightarrow> size ({# p \<in># ?M . p \<in> bl #}) = \<k>"
    using uniform k_non_zero uniform_unfold_point_set_mset by fastforce
  then have "size (\<Sum>bl\<in>#?B. ( {# p \<in># ?M . p \<in> bl #} \<times># {#bl#})) = size (?B) * \<k>"
    using mset_points_distinct size_Union_distinct_cart_prod_filter2 by blast
  thus ?thesis using k_non_zero by (simp add: set_break_down_right)
qed

lemma necessary_condition_two:
  shows "\<v> * \<r> = \<b> * \<k>"
  using necess_cond_2_lhs necess_cond_2_rhs by simp

theorem admissability_conditions:
"\<r> * (\<k> - 1) = \<Lambda> * (\<v> - 1)"
"\<v> * \<r> = \<b> * \<k>"
  using necessary_condition_one necessary_condition_two by auto

subsubsection \<open>BIBD Param Relationships\<close>

lemma bibd_block_number: "\<b> = \<Lambda> * \<v> * (\<v> - 1) div (\<k> * (\<k>-1))"
proof -
  have "\<b> * \<k> = (\<v> * \<r>)" using necessary_condition_two by simp
  then have k_dvd: "\<k> dvd (\<v> * \<r>)" by (metis dvd_triv_right)
  then have "\<b> = (\<v> * \<r>) div \<k>" using necessary_condition_two min_block_size_2 by auto
  then have "\<b> = (\<v> * ((\<Lambda> * (\<v> - 1) div (\<k> - 1)))) div \<k>" by simp
  then have "\<b> = (\<v> * \<Lambda> * (\<v> - 1)) div ((\<k> - 1)* \<k>)" using necessary_condition_one
      necessary_condition_two dvd_div_div_eq_mult dvd_div_eq_0_iff dvd_triv_right mult.assoc
      mult.commute mult.left_commute mult_eq_0_iff
    by (smt (z3) b_non_zero)
  then show ?thesis by (simp add: mult.commute)
qed

lemma symmetric_condition_1: "\<Lambda> * (\<v> - 1) = \<k> * (\<k> - 1) \<Longrightarrow> \<b> = \<v> \<and> \<r> = \<k>"
  using b_non_zero bibd_block_number mult_eq_0_iff necessary_condition_two necessary_condition_one
  by auto

lemma index_lt_replication: "\<Lambda> < \<r>"
proof -
  have 1: "\<r> * (\<k> - 1) = \<Lambda> * (\<v> - 1)" using admissability_conditions by simp
  have lhsnot0: "\<r> * (\<k> - 1) \<noteq> 0"
    using no_zero_divisors rep_not_zero by (metis div_by_0)
  then have rhsnot0: "\<Lambda> * (\<v> - 1) \<noteq> 0" using 1 by presburger
  have "\<k> - 1 < \<v> - 1" using incomplete b_non_zero bibd_block_number not_less_eq by fastforce
  thus ?thesis using 1 lhsnot0 rhsnot0 k_non_zero mult_le_less_imp_less r_gzero
    by (metis div_greater_zero_iff less_or_eq_imp_le nat_less_le nat_neq_iff)
qed

lemma index_not_zero: "\<Lambda> \<ge> 1"
  by (metis div_0 leI less_one mult_not_zero rep_not_zero)

lemma r_ge_two: "\<r> \<ge> 2"
  using index_lt_replication index_not_zero by linarith

lemma block_num_gt_rep: "\<b> > \<r>"
proof -
  have fact: "\<b> * \<k> = \<v> * \<r>" using admissability_conditions by auto
  have lhsnot0: "\<b> * \<k> \<noteq> 0" using k_non_zero b_non_zero by auto
  then have rhsnot0: "\<v> * \<r> \<noteq> 0" using fact by simp
  then show ?thesis using incomplete lhsnot0
    using complement_rep_number constant_rep_design.r_gzero incomplete_imp_incomp_block by fastforce
qed

lemma bibd_subset_occ:
  assumes "x \<subseteq> bl" and "bl \<in># \<B>" and "card x = 2"
  shows "size {# blk \<in># (\<B> - {#bl#}). x \<subseteq> blk #} = \<Lambda> - 1"
proof -
  have index: "size {# blk \<in># \<B>. x \<subseteq> blk #} = \<Lambda>" using points_index_def balanced assms
    by (metis (full_types) subset_eq wf_invalid_point)
  then have "size {# blk \<in># (\<B> - {#bl#}). x \<subseteq> blk #} = size {# blk \<in># \<B>. x \<subseteq> blk #} - 1"
    by (simp add: assms size_Diff_singleton)
  then show ?thesis using assms index_not_zero index by simp
qed

lemma necess_cond_one_param_balance: "\<b> > \<v> \<Longrightarrow> \<r> > \<k>"
  using necessary_condition_two b_positive
  by (metis div_le_mono2 div_mult_self1_is_m div_mult_self_is_m nat_less_le r_gzero v_non_zero)

subsection \<open>Constructing New bibd's\<close>
text \<open>There are many constructions on bibd's to establish new bibds (or other types of designs).
This section demonstrates this using both existing constructions, and by defining new constructions.\<close>
subsubsection \<open>BIBD Complement, Multiple, Combine\<close>

lemma comp_params_index_pair:
  assumes "{x, y} \<subseteq> \<V>"
  assumes "x \<noteq> y"
  shows "\<B>\<^sup>C index {x, y} = \<b> + \<Lambda> - 2*\<r>"
proof -
  have xin: "x \<in> \<V>" and yin: "y \<in> \<V>" using assms by auto
  have ge: "2*\<r> \<ge> \<Lambda>" using index_lt_replication
    using r_gzero by linarith
  have lambda: "size {# b \<in># \<B> . x \<in> b \<and> y \<in> b#} = \<Lambda>" using points_index_pair assms by simp
  have s1: "\<B>\<^sup>C index {x, y} = size {# b \<in># \<B> . x \<notin> b \<and> y \<notin> b #}"
    using complement_index_2 assms by simp
  also have s2: "... = size \<B> - (size {# b \<in># \<B> . \<not> (x \<notin> b \<and> y \<notin> b) #})"
    using size_filter_neg by blast
  also have "... = size \<B> - (size {# b \<in># \<B> . x \<in> b \<or> y \<in> b#})" by auto
  also have "... = \<b> - (size {# b \<in># \<B> . x \<in> b \<or> y \<in> b#})" by (simp add: of_nat_diff)
  finally have "\<B>\<^sup>C index {x, y} = \<b> - (size {# b \<in># \<B> . x \<in> b#} +
    size {# b \<in># \<B> . y \<in> b#} -  size {# b \<in># \<B> . x \<in> b \<and> y \<in> b#})"
    by (simp add: mset_size_partition_dep s2 s1)
  then have "\<B>\<^sup>C index {x, y} = \<b> - (\<r> + \<r> - \<Lambda>)" using rep_number_unfold_set lambda xin yin
    by presburger
  then have "\<B>\<^sup>C index {x, y} = \<b> - (2*\<r> - \<Lambda>)"
    using index_lt_replication by (metis mult_2)
  thus ?thesis using ge diff_diff_right by simp
qed

lemma complement_bibd_index:
  assumes "ps \<subseteq> \<V>"
  assumes "card ps = 2"
  shows "\<B>\<^sup>C index ps = \<b> + \<Lambda> - 2*\<r>"
proof -
  obtain x y where set: "ps = {x, y}" using b_non_zero bibd_block_number diff_is_0_eq incomplete
    mult_0_right nat_less_le design_points_nempty assms by (metis card_2_iff)
  then have "x \<noteq> y" using assms by auto
  thus ?thesis using comp_params_index_pair assms
    by (simp add: set)
qed

lemma complement_bibd:
  assumes "\<k> \<le> \<v> - 2"
  shows "bibd \<V> \<B>\<^sup>C (\<v> - \<k>) (\<b> + \<Lambda> - 2*\<r>)"
proof -
  interpret des: incomplete_design \<V> "\<B>\<^sup>C" "(\<v> - \<k>)"
    using assms complement_incomplete by blast
  show ?thesis proof (unfold_locales, simp_all)
    show "2 \<le> des.\<v>" using assms block_size_t by linarith
    show "\<And>ps. ps \<subseteq> \<V> \<Longrightarrow> card ps = 2 \<Longrightarrow>
      \<B>\<^sup>C index ps = \<b> + \<Lambda> - 2 * (\<Lambda> * (des.\<v> - Suc 0) div (\<k> - Suc 0))"
      using complement_bibd_index by simp
    show "2 \<le> des.\<v> - \<k>" using assms block_size_t by linarith
  qed
qed

lemma multiple_bibd: "n > 0 \<Longrightarrow> bibd \<V> (multiple_blocks n) \<k> (\<Lambda> * n)"
  using multiple_t_design by (simp add: bibd_def)

end

locale two_bibd_eq_points = two_t_designs_eq_points \<V> \<B> \<k> \<B>' 2 \<Lambda> \<Lambda>'
  + des1: bibd \<V> \<B> \<k> \<Lambda> + des2: bibd \<V> \<B>' \<k> \<Lambda>' for \<V> \<B> \<k> \<B>' \<Lambda> \<Lambda>'
begin

lemma combine_is_bibd: "bibd \<V>\<^sup>+ \<B>\<^sup>+ \<k> (\<Lambda> + \<Lambda>')"
  by (unfold_locales)

sublocale combine_bibd: bibd "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>" "(\<Lambda> + \<Lambda>')"
  by (unfold_locales)

end

subsubsection \<open>Derived Designs\<close>
text \<open>A derived bibd takes a block from a valid bibd as the new point sets, and the intersection
of that block with other blocks as it's block set\<close>

locale bibd_block_transformations = bibd +
  fixes block :: "'a set" ("bl")
  assumes valid_block: "bl \<in># \<B>"
begin

definition derived_blocks :: "'a set multiset" ("(\<B>\<^sup>D)") where
"\<B>\<^sup>D \<equiv> {# bl \<inter> b . b \<in># (\<B> - {#bl#}) #}"

lemma derive_define_flip: "{# b \<inter> bl . b \<in># (\<B> - {#bl#}) #} = \<B>\<^sup>D"
  by (simp add: derived_blocks_def inf_sup_aci(1))

lemma derived_points_order: "card bl = \<k>"
  using uniform valid_block by simp

lemma derived_block_num: "bl \<in># \<B> \<Longrightarrow> size \<B>\<^sup>D = \<b> - 1"
  by (simp add: derived_blocks_def size_remove1_mset_If valid_block)

lemma derived_is_wellformed:  "b \<in># \<B>\<^sup>D \<Longrightarrow> b \<subseteq> bl"
  by (simp add: derived_blocks_def valid_block) (auto)

lemma derived_point_subset_orig: "ps \<subseteq> bl \<Longrightarrow> ps \<subset> \<V>"
  by (simp add: valid_block incomplete_imp_proper_subset subset_psubset_trans)

lemma derived_obtain_orig_block:
  assumes "b \<in># \<B>\<^sup>D"
  obtains b2 where "b = b2 \<inter> bl" and "b2 \<in># remove1_mset bl \<B>"
  using assms derived_blocks_def by auto

sublocale derived_incidence_sys: incidence_system "bl" "\<B>\<^sup>D"
  using derived_is_wellformed valid_block by (unfold_locales) (auto)

sublocale derived_fin_incidence_system: finite_incidence_system "bl" "\<B>\<^sup>D"
  using valid_block finite_blocks by (unfold_locales) simp_all

lemma derived_blocks_nempty:
  assumes "\<And> b .b \<in># remove1_mset bl \<B> \<Longrightarrow> bl |\<inter>| b > 0"
  assumes "bld \<in># \<B>\<^sup>D"
  shows "bld \<noteq> {}"
proof -
  obtain bl2 where inter: "bld = bl2 \<inter> bl" and member: "bl2 \<in># remove1_mset bl \<B>"
    using assms derived_obtain_orig_block by blast
  then have "bl |\<inter>| bl2 > 0" using assms(1) by blast
  thus ?thesis using intersection_number_empty_iff finite_blocks valid_block
    by (metis Int_commute dual_order.irrefl inter)
qed

lemma derived_is_design:
  assumes "\<And> b. b \<in># remove1_mset bl \<B> \<Longrightarrow> bl |\<inter>| b > 0"
  shows "design bl \<B>\<^sup>D"
proof -
  interpret fin: finite_incidence_system "bl" "\<B>\<^sup>D"
    by (unfold_locales)
  show ?thesis using assms derived_blocks_nempty by (unfold_locales) simp
qed

lemma derived_is_proper:
  assumes "\<And> b. b \<in># remove1_mset bl \<B> \<Longrightarrow> bl |\<inter>| b > 0"
  shows "proper_design bl \<B>\<^sup>D"
proof -
  interpret des: design "bl" "\<B>\<^sup>D"
    using derived_is_design assms by fastforce
  have "\<b> - 1 > 1" using block_num_gt_rep r_ge_two by linarith
  then show ?thesis by (unfold_locales) (simp add: derived_block_num valid_block)
qed

subsubsection \<open>Residual Designs\<close>
text \<open>Similar to derived designs, a residual design takes the complement of a block bl as it's new
point set, and the complement of all other blocks with respect to bl.\<close>

definition residual_blocks :: "'a set multiset" ("(\<B>\<^sup>R)") where
"\<B>\<^sup>R \<equiv> {# b - bl . b \<in># (\<B> - {#bl#}) #}"

lemma residual_order: "card (bl\<^sup>c) = \<v> - \<k>"
  by (simp add: valid_block wellformed block_complement_size)

lemma residual_block_num: "size (\<B>\<^sup>R) = \<b> - 1"
  using b_positive by (simp add: residual_blocks_def size_remove1_mset_If valid_block int_ops(6))

lemma residual_obtain_orig_block:
  assumes "b \<in># \<B>\<^sup>R"
  obtains bl2 where "b = bl2 - bl" and "bl2 \<in># remove1_mset bl \<B>"
  using assms residual_blocks_def by auto

lemma residual_blocks_ss: assumes "b \<in># \<B>\<^sup>R" shows "b \<subseteq> \<V>"
proof -
  have "b \<subseteq> (bl\<^sup>c)" using residual_obtain_orig_block
    by (metis Diff_mono assms block_complement_def in_diffD order_refl wellformed)
  thus ?thesis
    using block_complement_subset_points by auto
qed

lemma residual_blocks_exclude: "b \<in># \<B>\<^sup>R \<Longrightarrow> x \<in> b \<Longrightarrow> x \<notin> bl"
  using residual_obtain_orig_block by auto

lemma residual_is_wellformed:  "b \<in># \<B>\<^sup>R \<Longrightarrow> b \<subseteq> (bl\<^sup>c)"
  apply (auto simp add: residual_blocks_def)
  by (metis DiffI block_complement_def in_diffD wf_invalid_point)

sublocale residual_incidence_sys: incidence_system "bl\<^sup>c" "\<B>\<^sup>R"
  using residual_is_wellformed by (unfold_locales)

lemma residual_is_finite: "finite (bl\<^sup>c)"
  by (simp add: block_complement_def finite_sets)

sublocale residual_fin_incidence_sys: finite_incidence_system "bl\<^sup>c" "\<B>\<^sup>R"
  using residual_is_finite by (unfold_locales)

lemma residual_blocks_nempty:
  assumes "bld \<in># \<B>\<^sup>R"
  assumes "multiplicity bl = 1"
  shows "bld \<noteq> {}"
proof -
  obtain bl2 where inter: "bld = bl2 - bl" and member: "bl2 \<in># remove1_mset bl \<B>"
    using assms residual_blocks_def by auto
  then have ne: "bl2 \<noteq> bl" using assms
    by (metis count_eq_zero_iff in_diff_count less_one union_single_eq_member)
  have "card bl2 = card bl" using uniform valid_block member
    using in_diffD by fastforce
  then have "card (bl2 - bl) > 0"
    using finite_blocks member uniform set_card_diff_ge_zero valid_block by (metis in_diffD ne)
  thus ?thesis using inter by fastforce
qed

lemma residual_is_design: "multiplicity bl = 1 \<Longrightarrow> design (bl\<^sup>c) \<B>\<^sup>R"
  using residual_blocks_nempty by (unfold_locales)

lemma residual_is_proper:
  assumes "multiplicity bl = 1"
  shows "proper_design (bl\<^sup>c) \<B>\<^sup>R"
proof -
  interpret des: design "bl\<^sup>c" "\<B>\<^sup>R" using residual_is_design assms by blast
  have "\<b> - 1 > 1" using r_ge_two block_num_gt_rep by linarith
  then show ?thesis using residual_block_num by (unfold_locales) auto
qed

end

subsection \<open>Symmetric BIBD's\<close>
text \<open>Symmetric bibd's are those where the order of the design equals the number of blocks\<close>

locale symmetric_bibd = bibd +
  assumes symmetric: "\<b> = \<v>"
begin

lemma rep_value_sym: "\<r> = \<k>"
  using b_non_zero local.symmetric necessary_condition_two by auto

lemma symmetric_condition_2: "\<Lambda> * (\<v> - 1) = \<k> * (\<k> - 1)"
  using necessary_condition_one rep_value_sym by auto

lemma sym_design_vk_gt_kl:
  assumes "\<k> \<ge> \<Lambda> + 2"
  shows "\<v> - \<k> > \<k> - \<Lambda>"
proof (rule ccontr)
  define k l v where kdef: "k \<equiv> int \<k>" and ldef: "l \<equiv> int \<Lambda>" and vdef: "v \<equiv> int \<v>"
  assume "\<not> (\<v> - \<k> > \<k> - \<Lambda>)"
  then have a: "\<not> (v - k > k - l)" using kdef ldef vdef
    by (metis block_size_lt_v index_lt_replication less_imp_le_nat of_nat_diff of_nat_less_imp_less
        rep_value_sym)
  have lge: "l \<ge> 0" using ldef by simp
  have sym: "l * (v- 1) = k * (k - 1)"
    using symmetric_condition_2 ldef vdef kdef
    by (metis (mono_tags, lifting) block_size_lt_v int_ops(2) k_non_zero le_trans of_nat_diff of_nat_mult)
  then have "v \<le> 2 * k - l" using a by linarith
  then have "v - 1 \<le> 2 * k - l - 1" by linarith
  then have "l* (v - 1) \<le> l*( 2 * k - l - 1)"
    using lge mult_le_cancel_left by fastforce
  then have "k * (k - 1) \<le> l*( 2 * k - l - 1)"
    by (simp add: sym)
  then have "k * (k - 1) - l*( 2 * k - l - 1) \<le> 0" by linarith
  then have "k^2 - k - l* 2 * k + l^2 + l \<le> 0" using  mult.commute right_diff_distrib'
    by (smt (z3) mult_cancel_left1 power2_diff ring_class.ring_distribs(2))
  then have "(k - l)*(k - l - 1) \<le> 0" using  mult.commute right_diff_distrib'
    by (smt (z3) \<open>k * (k - 1) \<le> l * (2 * k - l - 1)\<close> combine_common_factor)
  then have "k = l \<or> k = l + 1"
    using mult_le_0_iff by force
  thus False using assms kdef ldef by auto
qed

end

context bibd
begin

lemma symmetric_bibdI: "\<b> = \<v> \<Longrightarrow> symmetric_bibd \<V> \<B> \<k> \<Lambda>"
  by unfold_locales simp

lemma symmetric_bibdII: "\<Lambda> * (\<v> - 1) = \<k> * (\<k> - 1) \<Longrightarrow> symmetric_bibd \<V> \<B> \<k> \<Lambda>"
  using symmetric_condition_1 by unfold_locales blast

lemma symmetric_not_admissable: "\<Lambda> * (\<v> - 1) \<noteq> \<k> * (\<k> - 1) \<Longrightarrow> \<not> symmetric_bibd \<V> \<B> \<k> \<Lambda>"
  using symmetric_bibd.symmetric_condition_2 by blast
end

context symmetric_bibd
begin

subsubsection \<open>Intersection Property on Symmetric BIBDs\<close>
text \<open>Below is a proof of an important property on symmetric BIBD's regarding the equivalence
of intersection numbers and the design index. This is an intuitive counting proof, and involved
significantly more work in a formal environment. Based of Lecture Note \<^cite>\<open>"HerkeLectureNotes2016"\<close>\<close>

lemma intersect_mult_set_eq_block:
  assumes "blv \<in># \<B>"
  shows "p \<in># \<Sum>\<^sub>#{# mset_set (bl \<inter> blv) .bl \<in># (\<B> - {#blv#})#} \<longleftrightarrow> p \<in> blv"
proof (auto, simp add: assms finite_blocks)
  assume assm: "p \<in> blv"
  then have "(\<B> - {#blv#}) rep p > 0" using bibd_point_occ_rep r_ge_two assms by auto
  then obtain bl where "bl \<in># (\<B> - {#blv#}) \<and> p \<in> bl" using assms rep_number_g0_exists by metis
  then show "\<exists>x\<in>#remove1_mset blv \<B>. p \<in># mset_set (x \<inter> blv)"
    using assms assm finite_blocks by auto
qed

lemma intersect_mult_set_block_subset_iff:
  assumes "blv \<in># \<B>"
  assumes "p \<in># \<Sum>\<^sub>#{# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} .b2 \<in># (\<B> - {#blv#})#}"
  shows "p \<subseteq> blv"
proof (rule subsetI)
  fix x
  assume asm: "x \<in> p"
  obtain b2 where "p \<in># mset_set {y . y \<subseteq> blv \<inter> b2 \<and> card y = 2} \<and> b2 \<in>#(\<B> - {#blv#})"
    using assms by blast
  then have "p \<subseteq> blv \<inter> b2"
    by (metis (no_types, lifting) elem_mset_set equals0D infinite_set_mset_mset_set mem_Collect_eq)
  thus "x \<in> blv" using asm by auto
qed

lemma intersect_mult_set_block_subset_card:
  assumes "blv \<in># \<B>"
  assumes "p \<in># \<Sum>\<^sub>#{# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} .b2 \<in># (\<B> - {#blv#})#}"
  shows "card p = 2"
proof -
  obtain b2 where "p \<in># mset_set {y . y \<subseteq> blv \<inter> b2 \<and> card y = 2} \<and> b2 \<in>#(\<B> - {#blv#})"
    using assms by blast
  thus ?thesis
    by (metis (mono_tags, lifting) elem_mset_set equals0D infinite_set_mset_mset_set mem_Collect_eq)
qed

lemma intersect_mult_set_block_with_point_exists:
  assumes "blv \<in># \<B>" and  "p \<subseteq> blv" and "\<Lambda> \<ge> 2" and "card p = 2"
  shows "\<exists>x\<in>#remove1_mset blv \<B>. p \<in># mset_set {y. y \<subseteq> blv \<and> y \<subseteq> x \<and> card y = 2}"
proof -
  have "size {#b \<in># \<B> . p \<subseteq> b#} = \<Lambda>" using points_index_def assms
    by (metis balanced_alt_def_all dual_order.trans wellformed)
  then have "size {#bl \<in># (\<B> - {#blv#}) . p \<subseteq> bl#} \<ge> 1"
    using assms by (simp add: size_Diff_singleton)
  then obtain bl where "bl \<in># (\<B> - {#blv#}) \<and> p \<subseteq> bl" using assms filter_mset_empty_conv
     by (metis diff_diff_cancel diff_is_0_eq' le_numeral_extra(4) size_empty zero_neq_one)
  thus ?thesis
    using assms finite_blocks by auto
qed

lemma intersect_mult_set_block_subset_iff_2:
  assumes "blv \<in># \<B>" and  "p \<subseteq> blv" and "\<Lambda> \<ge> 2" and "card p = 2"
  shows "p \<in># \<Sum>\<^sub>#{# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} .b2 \<in># (\<B> - {#blv#})#}"
  by (auto simp add: intersect_mult_set_block_with_point_exists assms)

lemma sym_sum_mset_inter_sets_count:
  assumes "blv \<in># \<B>"
  assumes "p \<in> blv"
  shows "count (\<Sum>\<^sub>#{# mset_set (bl \<inter> blv) .bl \<in># (\<B> - {#blv#})#}) p = \<r> - 1"
    (is "count (\<Sum>\<^sub>#?M) p = \<r> - 1")
proof -
  have size_inter: "size {# mset_set (bl \<inter> blv) | bl  \<in># (\<B> - {#blv#}) . p \<in> bl#} = \<r> - 1"
    using bibd_point_occ_rep point_replication_number_def
    by (metis assms(1) assms(2) size_image_mset)
  have inter_finite: "\<forall> bl \<in># (\<B> - {#blv#}) . finite (bl \<inter> blv)"
    by (simp add: assms(1) finite_blocks)
  have "\<And> bl . bl \<in># (\<B> - {#blv#}) \<Longrightarrow> p \<in> bl \<longrightarrow> count (mset_set (bl \<inter> blv)) p = 1"
    using assms count_mset_set(1) inter_finite by simp
  then have "\<And> bl . bl \<in># {#b1 \<in>#(\<B> - {#blv#}) . p \<in> b1#} \<Longrightarrow> count (mset_set (bl \<inter> blv)) p = 1"
    by (metis (full_types) count_eq_zero_iff count_filter_mset)
  then have pin: "\<And> P. P \<in># {# mset_set (bl \<inter> blv) | bl \<in># (\<B> - {#blv#}) . p \<in> bl#}
      \<Longrightarrow> count P p = 1" by blast
  have "?M = {# mset_set (bl \<inter> blv) | bl \<in># (\<B> - {#blv#}) . p \<in> bl#}
      + {# mset_set (bl \<inter> blv) | bl \<in># (\<B> - {#blv#}) . p \<notin> bl#}"
    by (metis image_mset_union multiset_partition)
  then have "count (\<Sum>\<^sub>#?M) p = size {# mset_set (bl \<inter> blv) | bl \<in># (\<B> - {#blv#}) . p \<in> bl#} "
    using pin by (auto simp add: count_sum_mset)
  then show ?thesis using size_inter by linarith
qed

lemma sym_sum_mset_inter_sets_size:
  assumes "blv \<in># \<B>"
  shows "size (\<Sum>\<^sub>#{# mset_set (bl \<inter> blv) .bl \<in># (\<B> - {#blv#})#}) = \<k> * (\<r> - 1)"
    (is "size (\<Sum>\<^sub>#?M) = \<k>* (\<r> - 1)")
proof -
  have eq: "set_mset (\<Sum>\<^sub>#{# mset_set (bl \<inter> blv) .bl \<in># (\<B> - {#blv#})#}) = blv"
    using intersect_mult_set_eq_block assms by auto
  then have k: "card (set_mset (\<Sum>\<^sub>#?M)) = \<k>"
    by (simp add: assms)
  have "\<And> p. p \<in># (\<Sum>\<^sub>#?M) \<Longrightarrow> count (\<Sum>\<^sub>#?M) p = \<r> - 1"
    using sym_sum_mset_inter_sets_count assms eq by blast
  thus ?thesis using k size_multiset_set_mset_const_count by metis
qed

lemma sym_sum_inter_num:
  assumes "b1 \<in># \<B>"
  shows "(\<Sum>b2 \<in>#(\<B> - {#b1#}). b1 |\<inter>| b2) = \<k>* (\<r> - 1)"
proof -
  have "(\<Sum>b2 \<in>#(\<B> - {#b1#}). b1 |\<inter>| b2) = (\<Sum>b2 \<in>#(\<B> - {#b1#}). size (mset_set (b1 \<inter> b2)))"
    by (simp add: intersection_number_def)
  also have "... = size (\<Sum>\<^sub>#{#mset_set (b1 \<inter> bl). bl \<in># (\<B> - {#b1#})#})"
    by (auto simp add: size_big_union_sum)
  also have "... =  size (\<Sum>\<^sub>#{#mset_set (bl \<inter> b1). bl \<in># (\<B> - {#b1#})#})"
    by (metis Int_commute)
  finally have "(\<Sum>b2 \<in>#(\<B> - {#b1#}). b1 |\<inter>| b2) = \<k> * (\<r> - 1)"
    using sym_sum_mset_inter_sets_size assms by auto
  then show ?thesis by simp
qed

lemma sym_sum_mset_inter2_sets_count:
  assumes "blv \<in># \<B>"
  assumes "p \<subseteq> blv"
  assumes "card p = 2"
  shows "count (\<Sum>\<^sub>#{#mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2}. b2 \<in># (\<B> - {#blv#})#}) p = \<Lambda> - 1"
    (is "count (\<Sum>\<^sub>#?M) p = \<Lambda> - 1")
proof -
  have size_inter: "size {# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} | b2 \<in># (\<B> - {#blv#}) . p \<subseteq> b2#}
      = \<Lambda> - 1"
    using bibd_subset_occ assms by simp
  have "\<forall> b2 \<in># (\<B> - {#blv#}) . p \<subseteq> b2 \<longrightarrow> count (mset_set{y .y \<subseteq> blv \<inter> b2 \<and> card y = 2}) p = 1"
    using assms(2) count_mset_set(1) assms(3) by (auto simp add: assms(1) finite_blocks)
  then have "\<forall> bl \<in># {#b1 \<in>#(\<B> - {#blv#}) . p \<subseteq> b1#}.
      count (mset_set {y .y \<subseteq> blv \<inter> bl \<and> card y = 2}) p = 1"
    using count_eq_zero_iff count_filter_mset by (metis (no_types, lifting))
  then have pin: "\<forall> P \<in># {# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} | b2 \<in># (\<B> - {#blv#}) . p \<subseteq> b2#}.
      count P p = 1"
    using count_eq_zero_iff count_filter_mset by blast
  have "?M = {# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} | b2 \<in># (\<B> - {#blv#}) . p \<subseteq> b2#} +
              {# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} | b2 \<in># (\<B> - {#blv#}) . \<not> (p \<subseteq> b2)#}"
    by (metis image_mset_union multiset_partition)
  then have "count (\<Sum>\<^sub>#?M) p =
      size {# mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2} | b2 \<in># (\<B> - {#blv#}) . p \<subseteq> b2#}"
    using pin by (auto simp add: count_sum_mset)
  then show ?thesis using size_inter by linarith
qed

lemma sym_sum_mset_inter2_sets_size:
  assumes "blv \<in># \<B>"
  shows "size (\<Sum>\<^sub>#{#mset_set {y .y \<subseteq> blv \<inter> b2 \<and> card y = 2}. b2 \<in># (\<B> - {#blv#})#}) =
    ( \<k> choose 2) * (\<Lambda> -1)"
    (is "size (\<Sum>\<^sub>#?M) = (\<k> choose 2) * (\<Lambda> -1)")
proof (cases "\<Lambda> = 1")
  case True
  have empty: "\<And> b2 . b2 \<in># remove1_mset blv \<B> \<Longrightarrow> {y .y \<subseteq> blv \<and> y \<subseteq> b2 \<and> card y = 2} = {}"
    using index_one_alt_bl_not_exist assms True by blast
  then show ?thesis using sum_mset.neutral True by (simp add: empty)
next
  case False
  then have index_min: "\<Lambda> \<ge> 2" using index_not_zero by linarith
  have subset_card: "\<And> x . x \<in># (\<Sum>\<^sub>#?M) \<Longrightarrow> card x = 2"
  proof -
    fix x
    assume a: "x \<in># (\<Sum>\<^sub>#?M)"
    then obtain b2 where "x \<in># mset_set {y . y \<subseteq> blv \<inter> b2 \<and> card y = 2} \<and> b2 \<in>#(\<B> - {#blv#})"
      by blast
    thus "card x = 2" using mem_Collect_eq
      by (metis (mono_tags, lifting) elem_mset_set equals0D infinite_set_mset_mset_set)
  qed
  have eq: "set_mset (\<Sum>\<^sub>#?M) = {bl . bl \<subseteq> blv \<and> card bl = 2}"
  proof
    show "set_mset (\<Sum>\<^sub>#?M) \<subseteq> {bl . bl \<subseteq> blv \<and> card bl = 2}"
      using subset_card intersect_mult_set_block_subset_iff assms by blast
    show "{bl . bl \<subseteq> blv \<and> card bl = 2} \<subseteq> set_mset (\<Sum>\<^sub>#?M)"
      using intersect_mult_set_block_subset_iff_2 assms index_min by blast
  qed
  have "card blv =  \<k>" using uniform assms by simp
  then have k: "card (set_mset (\<Sum>\<^sub>#?M)) = (\<k> choose 2)" using eq n_subsets
    by (simp add: n_subsets assms finite_blocks)
  thus ?thesis using k size_multiset_set_mset_const_count sym_sum_mset_inter2_sets_count assms eq
    by (metis (no_types, lifting) intersect_mult_set_block_subset_iff subset_card)
qed

lemma sum_choose_two_inter_num:
  assumes "b1 \<in># \<B>"
  shows "(\<Sum>b2 \<in># (\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2)) = ((\<Lambda> * (\<Lambda> - 1) div 2)) * (\<v> -1)"
proof -
  have div_fact: "2 dvd (\<Lambda> * (\<Lambda> - 1))"
    by fastforce
  have div_fact_2: "2 dvd (\<Lambda> * (\<v> - 1))" using symmetric_condition_2 by fastforce
  have "(\<Sum>b2 \<in># (\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2)) = (\<Sum>b2 \<in># (\<B> - {#b1#}). (b1 |\<inter>|\<^sub>2 b2 ))"
    using n_inter_num_choose_design_inter assms by (simp add: in_diffD)
  then have sum_fact: "(\<Sum>b2 \<in># (\<B> - {#b1#}).((b1 |\<inter>| b2) choose 2))
      = (\<k> choose 2) * (\<Lambda> -1)"
    using assms sym_sum_mset_inter2_sets_size
    by (auto simp add: size_big_union_sum n_intersect_num_subset_def)
  have "(\<k> choose 2) * (\<Lambda> -1) = ((\<Lambda> * (\<v> - 1) div 2)) * (\<Lambda> -1)"
    using choose_two symmetric_condition_2 k_non_zero by auto
  then have "(\<k> choose 2) * (\<Lambda> -1) = ((\<Lambda> * (\<Lambda> - 1) div 2)) * (\<v> -1)"
    using div_fact div_fact_2 by (smt div_mult_swap mult.assoc mult.commute)
  then show ?thesis using sum_fact by simp
qed

lemma sym_sum_inter_num_sq:
  assumes "b1 \<in># \<B>"
  shows "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) = \<Lambda>^2 * ( \<v> - 1)"
proof -
  have dvd: "2 dvd (( \<v> - 1) * (\<Lambda> * (\<Lambda> - 1)))" by fastforce
  have inner_dvd: "\<forall> bl \<in># (remove1_mset b1 \<B>). 2 dvd ((b1 |\<inter>| bl) *  ((b1 |\<inter>| bl) - 1))"
    by force
  have diff_le: "\<And> bl . bl \<in># (remove1_mset b1 \<B>) \<Longrightarrow> (b1 |\<inter>| bl) \<le> (b1 |\<inter>| bl)^2"
    by (simp add: power2_nat_le_imp_le)
  have a: "(\<Sum>b2 \<in>#(\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2)) =
            (\<Sum>bl \<in># (remove1_mset b1 \<B>).  ((b1 |\<inter>| bl) *  ((b1 |\<inter>| bl) - 1)) div 2)"
    using choose_two by (simp add: intersection_num_non_neg)
  have b: "(\<Sum>b2 \<in>#(\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2)) =
              (\<Sum>b2 \<in>#(\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2))" by simp
  have gtsq: "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) \<ge> (\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl))"
    by (simp add: diff_le sum_mset_mono)
  have "(\<Sum>b2 \<in>#(\<B> - {#b1#}). ((b1 |\<inter>| b2) choose 2)) = ((\<Lambda> * (\<Lambda> - 1)) div 2) * ( \<v> - 1)"
    using sum_choose_two_inter_num assms by blast
  then have start: "(\<Sum>bl \<in># (remove1_mset b1 \<B>). ((b1 |\<inter>| bl) *  ((b1 |\<inter>| bl) - 1)) div 2)
                        = ((\<Lambda> * (\<Lambda> - 1)) div 2) * (\<v> - 1)"
    using a b by linarith
  have sum_dvd: "2 dvd (\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl) *  ((b1 |\<inter>| bl) - 1))"
    using sum_mset_dvd
    by (metis (no_types, lifting) dvd_mult dvd_mult2 dvd_refl odd_two_times_div_two_nat)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl) * ((b1 |\<inter>| bl) - 1)) div 2
      =  ((\<Lambda> * (\<Lambda> - 1)) div 2) * (\<v> - 1)"
    using start sum_mset_distrib_div_if_dvd inner_dvd
    by (metis (mono_tags, lifting) image_mset_cong2)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl) * ((b1 |\<inter>| bl) - 1)) div 2
      =  (\<v> - 1) * ((\<Lambda> * (\<Lambda> - 1)) div 2)"
    by simp
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl) * ((b1 |\<inter>| bl) - 1))
      =  (\<v> - 1) * (\<Lambda> * (\<Lambda> - 1))"
    by (metis (no_types, lifting) div_mult_swap dvdI dvd_div_eq_iff dvd_mult dvd_mult2 odd_two_times_div_two_nat sum_dvd)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2 - (b1 |\<inter>| bl))
      =  (\<v> - 1) * (\<Lambda> * (\<Lambda> - 1))"
    using diff_mult_distrib2
    by (metis (no_types, lifting) multiset.map_cong0 nat_mult_1_right power2_eq_square)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2)
      - (\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)) = (\<v> - 1) * (\<Lambda> * (\<Lambda> - 1))"
    using sum_mset_add_diff_nat[of "(remove1_mset b1 \<B>)" "\<lambda> bl . (b1 |\<inter>| bl)" "\<lambda> bl . (b1 |\<inter>| bl)^2"]
      diff_le by presburger
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2)
      = (\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)) + (\<v> - 1) * (\<Lambda> * (\<Lambda> - 1))" using gtsq
    by (metis le_add_diff_inverse)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) =  (\<Lambda> * (\<v> - 1)) + ((\<v> - 1) * (\<Lambda> * (\<Lambda> - 1)))"
    using sym_sum_inter_num assms rep_value_sym symmetric_condition_2 by auto
  then have prev: "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) = (\<Lambda> * (\<v> - 1)) * (\<Lambda> - 1) + (\<Lambda> * (\<v> - 1))"
    by fastforce
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) = (\<Lambda> * (\<v> - 1)) * (\<Lambda>)"
    by (metis Nat.le_imp_diff_is_add add_mult_distrib2 index_not_zero nat_mult_1_right)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (b1 |\<inter>| bl)^2) = \<Lambda> * \<Lambda> * (\<v> - 1)"
    using mult.commute by simp
  thus ?thesis by (simp add: power2_eq_square)
qed

lemma sym_sum_inter_num_to_zero:
  assumes "b1 \<in># \<B>"
  shows "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (int (b1 |\<inter>| bl) - (int \<Lambda>))^2) = 0"
proof -
  have rm1_size: "size (remove1_mset b1 \<B>) = \<v> - 1" using assms b_non_zero int_ops(6)
    by (auto simp add: symmetric size_remove1_mset_If)
  have  "(\<Sum>bl \<in># (remove1_mset b1 \<B>). ((int (b1 |\<inter>| bl))^2)) =
    (\<Sum>bl \<in># (remove1_mset b1 \<B>). (((b1 |\<inter>| bl))^2))" by simp
  then have ssi: "(\<Sum>bl \<in># (remove1_mset b1 \<B>). ((int (b1 |\<inter>| bl))^2)) = \<Lambda>^2 * (\<v> - 1)"
    using sym_sum_inter_num_sq assms by simp
  have "\<And> bl . bl \<in># (remove1_mset b1 \<B>) \<Longrightarrow> (int (b1 |\<inter>| bl) - (int \<Lambda>))^2 =
        (((int (b1 |\<inter>| bl))^2) - (2 * (int \<Lambda>) * (int (b1 |\<inter>| bl))) + ((int \<Lambda>)^2))"
    by (simp add: power2_diff)
  then have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (int (b1 |\<inter>| bl) - (int \<Lambda>))^2) =
              (\<Sum>bl \<in># (remove1_mset b1 \<B>). (((int (b1 |\<inter>| bl))^2) - (2 * (int \<Lambda>) * (int (b1 |\<inter>| bl))) + ((int \<Lambda>)^2)))"
    using sum_over_fun_eq by auto
  also have "... = (\<Sum>bl \<in># (remove1_mset b1 \<B>). (((int (b1 |\<inter>| bl))^2)
      -  (2 * (int \<Lambda>) * (int (b1 |\<inter>| bl))))) + (\<Sum> bl \<in># (remove1_mset b1 \<B>) . ((int \<Lambda>)^2))"
    by (simp add: sum_mset.distrib)
  also have "... = (\<Sum>bl \<in># (remove1_mset b1 \<B>). ((int (b1 |\<inter>| bl))^2))
      - (\<Sum>bl \<in># (remove1_mset b1 \<B>). (2 * (int \<Lambda>) * (int (b1 |\<inter>| bl)))) + (\<Sum> bl \<in># (remove1_mset b1 \<B>) . ((int \<Lambda>)^2))"
    using sum_mset_add_diff_int[of "(\<lambda> bl . ((int (b1 |\<inter>| bl))^2))" "(\<lambda> bl . (2 * (int \<Lambda>) * (int (b1 |\<inter>| bl))))" "(remove1_mset b1 \<B>)"]
    by simp
  also have "... =  \<Lambda>^2 * (\<v> - 1) - 2 * (int \<Lambda>) *(\<Sum>bl \<in># (remove1_mset b1 \<B>). ((b1 |\<inter>| bl)))
      + (\<v> - 1) * ((int \<Lambda>)^2)" using ssi rm1_size assms by (simp add: sum_mset_distrib_left)
  also have "... =  2 * \<Lambda>^2 * (\<v> - 1) - 2 * (int \<Lambda>) *(\<k>* (\<r> - 1))"
    using  sym_sum_inter_num assms by simp
  also have "... = 2 * \<Lambda>^2 * (\<v> - 1) - 2 * (int \<Lambda>) * (\<Lambda> * (\<v> - 1))"
    using rep_value_sym symmetric_condition_2 by simp
  finally have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (int (b1 |\<inter>| bl) - int \<Lambda>)^2) = 0"
    by (auto simp add: power2_eq_square)
  thus ?thesis by simp
qed

theorem sym_block_intersections_index [simp]:
  assumes "b1 \<in># \<B>"
  assumes "b2 \<in># (\<B> - {#b1#})"
  shows "b1 |\<inter>| b2 = \<Lambda>"
proof -
  define l where l_def: "l = int \<Lambda>"
  then have pos: "\<And> bl . (int (b1 |\<inter>| bl) - l)^2 \<ge> 0" by simp
  have "(\<Sum>bl \<in># (remove1_mset b1 \<B>). (int (b1 |\<inter>| bl) - l)^2) = 0"
    using sym_sum_inter_num_to_zero assms l_def by simp
  then have "\<And> bl.  bl \<in> set_mset (remove1_mset b1 \<B>) \<Longrightarrow> (int (b1 |\<inter>| bl) - l)^2 = 0"
    using sum_mset_0_iff_ge_0 pos by (metis (no_types, lifting))
  then have "\<And> bl.  bl \<in> set_mset (remove1_mset b1 \<B>) \<Longrightarrow> int (b1 |\<inter>| bl) = l"
    by auto
  thus ?thesis using assms(2) l_def of_nat_eq_iff by blast
qed

subsubsection \<open>Symmetric BIBD is Simple\<close>

lemma sym_block_mult_one [simp]:
  assumes "bl \<in># \<B>"
  shows "multiplicity bl = 1"
proof (rule ccontr)
  assume "\<not> (multiplicity bl = 1)"
  then have not: "multiplicity bl \<noteq> 1" by simp
  have "multiplicity bl \<noteq> 0" using assms
    by simp
  then have m: "multiplicity bl \<ge> 2" using not by linarith
  then have blleft: "bl \<in># (\<B> - {#bl#})"
    using in_diff_count by fastforce
  have "bl |\<inter>| bl = \<k>" using k_non_zero assms
    by (simp add: intersection_number_def)
  then have keql: "\<k> = \<Lambda>" using sym_block_intersections_index blleft assms by simp
  then have "\<v> = \<k>"
    using keql index_lt_replication rep_value_sym block_size_lt_v diffs0_imp_equal k_non_zero zero_diff by linarith
  then show False using incomplete
    by simp
qed

end

sublocale symmetric_bibd \<subseteq> simple_design
  by unfold_locales simp

subsubsection \<open>Residual/Derived Sym BIBD Constructions\<close>
text \<open>Using the intersect result, we can reason further on residual and derived designs.
Proofs based off lecture notes \<^cite>\<open>"HerkeLectureNotes2016"\<close>\<close>

locale symmetric_bibd_block_transformations = symmetric_bibd + bibd_block_transformations
begin

lemma derived_block_size [simp]:
  assumes "b \<in># \<B>\<^sup>D"
  shows "card b = \<Lambda>"
proof -
  obtain bl2 where set: "bl2 \<in># remove1_mset bl \<B>" and inter: "b = bl2 \<inter> bl"
    using derived_blocks_def assms by (meson derived_obtain_orig_block)
  then have "card b = bl2 |\<inter>| bl"
    by (simp add: intersection_number_def)
  thus ?thesis using sym_block_intersections_index
    using set intersect_num_commute valid_block by fastforce
qed

lemma derived_points_index [simp]:
  assumes "ps \<subseteq> bl"
  assumes "card ps = 2"
  shows "\<B>\<^sup>D index  ps = \<Lambda> - 1"
proof -
  have b_in: "\<And> b . b \<in># (remove1_mset bl \<B>) \<Longrightarrow> ps \<subseteq> b \<Longrightarrow> ps \<subseteq> b \<inter> bl"
    using assms by blast
  then have orig: "ps \<subseteq> \<V>"
    using valid_block assms wellformed by blast
  then have lam: "size {# b \<in># \<B> . ps \<subseteq> b #} = \<Lambda>" using balanced
    by (simp add: assms(2)  points_index_def)
  then have "size {# b \<in># remove1_mset bl \<B> . ps \<subseteq> b #} = size {# b \<in># \<B> . ps \<subseteq> b #} - 1"
    using assms valid_block by (simp add: size_Diff_submset)
  then have "size {# b \<in># remove1_mset bl \<B> . ps \<subseteq> b #} = \<Lambda> - 1"
    using lam index_not_zero by linarith
  then have "size  {# bl \<inter> b |  b \<in># (remove1_mset bl \<B>) . ps \<subseteq> bl \<inter> b #} = \<Lambda> - 1"
    using b_in by (metis (no_types, lifting) Int_subset_iff filter_mset_cong size_image_mset)
  then have "size {# x \<in># {# bl \<inter> b . b \<in># (remove1_mset bl \<B>) #} . ps \<subseteq> x #} = \<Lambda> - 1"
    by (metis image_mset_filter_swap)
  then have "size {# x \<in># \<B>\<^sup>D . ps \<subseteq> x #} = \<Lambda> - 1" by (simp add: derived_blocks_def)
  thus ?thesis by (simp add: points_index_def)
qed

lemma sym_derive_design_bibd:
  assumes "\<Lambda> > 1"
  shows "bibd bl \<B>\<^sup>D \<Lambda> (\<Lambda> - 1)"
proof -
  interpret des: proper_design bl "\<B>\<^sup>D" using derived_is_proper assms valid_block by auto
  have "\<Lambda> < \<k>" using index_lt_replication rep_value_sym by linarith
  then show ?thesis using derived_block_size assms derived_points_index derived_points_order
    by (unfold_locales) (simp_all)
qed

lemma residual_block_size [simp]:
  assumes "b \<in># \<B>\<^sup>R"
  shows "card b = \<k> - \<Lambda>"
proof -
  obtain bl2 where sub: "b = bl2 - bl" and mem: "bl2 \<in># remove1_mset bl \<B>"
    using assms residual_blocks_def by auto
  then have "card b = card bl2 - card (bl2 \<inter> bl)"
    using card_Diff_subset_Int valid_block finite_blocks
    by (simp add: card_Diff_subset_Int)
  then have "card b = card bl2 - bl2 |\<inter>| bl"
    using finite_blocks card_inter_lt_single by (simp add: intersection_number_def)
  thus ?thesis using sym_block_intersections_index uniform
    by (metis valid_block in_diffD intersect_num_commute mem)
qed

lemma residual_index [simp]:
  assumes "ps \<subseteq> bl\<^sup>c"
  assumes "card ps = 2"
  shows  "(\<B>\<^sup>R) index ps = \<Lambda>"
proof -
  have a: "\<And> b . (b \<in># remove1_mset bl \<B> \<Longrightarrow> ps \<subseteq> b \<Longrightarrow>  ps \<subseteq> (b - bl))" using assms
    by (smt DiffI block_comp_elem_alt_left in_diffD subset_eq wellformed)
  have b: "\<And> b . (b \<in># remove1_mset bl \<B> \<Longrightarrow>  ps \<subseteq> (b - bl) \<Longrightarrow>  ps \<subseteq> b)"
    by auto
  have not_ss: "\<not> (ps \<subseteq> bl)" using set_diff_non_empty_not_subset blocks_nempty t_non_zero assms
    block_complement_def by fastforce
  have "\<B>\<^sup>R index ps = size {# x \<in># {# b - bl . b \<in># (remove1_mset bl \<B>) #} . ps \<subseteq> x #}"
    using assms valid_block by (simp add: points_index_def residual_blocks_def)
  also have "... = size  {# b - bl |  b \<in># (remove1_mset bl \<B>) . ps \<subseteq> b - bl #} "
    by (metis image_mset_filter_swap)
  finally have "\<B>\<^sup>R index ps = size  {#  b \<in># (remove1_mset bl \<B>) . ps \<subseteq> b #} " using a b
    by (metis (no_types, lifting) filter_mset_cong size_image_mset)
  thus ?thesis
    using balanced not_ss assms points_index_alt_def block_complement_subset_points by auto
qed

lemma sym_residual_design_bibd:
  assumes "\<k> \<ge> \<Lambda> + 2"
  shows "bibd (bl\<^sup>c) \<B>\<^sup>R (\<k> - \<Lambda>) \<Lambda>"
proof -
  interpret des: proper_design "bl\<^sup>c" "\<B>\<^sup>R"
    using residual_is_proper assms(1) valid_block sym_block_mult_one by fastforce
  show ?thesis using residual_block_size assms sym_design_vk_gt_kl residual_order residual_index
    by(unfold_locales) simp_all
qed

end

subsection \<open>BIBD's and Other Block Designs\<close>
text \<open>BIBD's are closely related to other block designs by indirect inheritance\<close>

sublocale bibd \<subseteq> k_\<Lambda>_PBD \<V> \<B> \<Lambda> \<k>
  using block_size_gt_t by (unfold_locales) simp_all

lemma incomplete_PBD_is_bibd:
  assumes "k < card V" and "k_\<Lambda>_PBD V B \<Lambda> k"
  shows "bibd V B k \<Lambda>"
proof -
  interpret inc: incomplete_design V B k using assms
    by (auto simp add: block_design.incomplete_designI k_\<Lambda>_PBD.axioms(2))
  interpret pairwise_balance: pairwise_balance V B \<Lambda> using assms
    by (auto simp add: k_\<Lambda>_PBD.axioms(1))
  show ?thesis using assms k_\<Lambda>_PBD.block_size_t by (unfold_locales) (simp_all)
qed

lemma (in bibd) bibd_to_pbdI[intro]:
  assumes "\<Lambda> = 1"
  shows "k_PBD \<V> \<B> \<k>"
proof -
  interpret pbd: k_\<Lambda>_PBD \<V> \<B> \<Lambda> \<k>
    by (simp add: k_\<Lambda>_PBD_axioms)
  show ?thesis using assms by (unfold_locales) (simp_all add: t_lt_order min_block_size_2)
qed

locale incomplete_PBD = incomplete_design + k_\<Lambda>_PBD

sublocale incomplete_PBD \<subseteq> bibd
  using block_size_t by (unfold_locales) simp

end


(* Title: thys/TuringReducible.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

section \<open>Turing Reducibility\<close>

theory TuringReducible
  imports
    TuringDecidable
    StrongCopyTM
begin

subsection \<open>Definition of Turing Reducibility of Sets and Relations of Natural Numbers\<close>

(* See the book
   Computability, Complexity, and Languages,
   Davis, Sigal, Weyuker,
   Academic Press, 1983,
   ISBN 0-12-206382-1

   Chapter 4: Diagonalization and Reducibility, pp 91
*)

text \<open>Let @{term A} and @{term B} be two sets of lists of natural numbers.

The set @{term A} is called many-one reducible to set @{term B},
if there is a Turing machine @{term tm} such that
  for all @{term "a"} we have:

\begin{enumerate}
  \item the Turing machine always computes a list @{term "b"} of natural numbers
      from the list @{term "b"} of natural numbers

  \item @{term "a \<in> A"} if and only if
      the value @{term "b"} computed by @{term tm} from @{term "a"}
      is an element of set @{term "B"}.
\end{enumerate}

We generalized our definition to lists, which eliminates the need to encode lists of natural numbers into a single natural number.
Compare this to the theory of recursive functions, where all values computed must be a single natural number.

Note however, that our notion of reducibility is not stronger than the one used in recursion theory.
Every finite list of natural numbers can be encoded into a single natural number.
Our definition is just more convenient for Turing machines, which are capable of producing lists of values.
\<close>

definition turing_reducible :: "(nat list) set \<Rightarrow> (nat list) set  \<Rightarrow> bool"
  where

    "turing_reducible A B \<equiv>
         (\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list.
              \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <ml> @ Bk\<up> l))\<rbrace> \<and>
              (nl \<in> A \<longleftrightarrow> ml \<in> B)
         )"

(* This is for documentation and explanation: turing_reducible_unfolded_into_TMC_yields_condition *)

lemma turing_reducible_unfolded_into_TMC_yields_condition:
    "turing_reducible A B \<equiv>
         (\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list.
              TMC_yields_num_list_res tm nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)
         )"
  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
  by (simp add: turing_reducible_def)

subsection \<open>Theorems about Turing Reducibility of Sets and Relations of Natural Numbers\<close>

(* A convenience lemma for the main proof *)

lemma turing_reducible_A_B_imp_composable_reducer_ex: "turing_reducible A B
       \<Longrightarrow>
       \<exists>Red. composable_tm0 Red \<and>
             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
proof -
  assume "turing_reducible A B"
  then have "\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res tm nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
    using turing_reducible_unfolded_into_TMC_yields_condition by auto

  then obtain Red' where
    w_RedTM': "\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red' nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
    by blast

  (* create a composable version Red from the potentially non-composable machine Red' *)

  then have "composable_tm0 (mk_composable0 Red') \<and>
             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res (mk_composable0 Red') nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
    using w_RedTM' Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_rev Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list composable_tm0_mk_composable0
    using TMC_yields_num_list_res_unfolded_into_Hoare_halt by blast

  then show "\<exists>Red. composable_tm0 Red \<and>
             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
    by (rule exI)
qed

(* The main theorem about problem reduction *)

theorem turing_reducible_AB_and_decB_imp_decA:
  "\<lbrakk> turing_reducible A B; turing_decidable B \<rbrakk> \<Longrightarrow> turing_decidable A"
proof -
  assume "turing_reducible A B"
    and  "turing_decidable B"

  (* first, obtain a composable reducer machine Red *)

  from \<open>turing_reducible A B\<close>
  have "\<exists>Red. composable_tm0 Red \<and>
               (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
    by (rule turing_reducible_A_B_imp_composable_reducer_ex)

  then obtain Red where
    w_RedTM: "composable_tm0 Red \<and>
               (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
    by blast

  (* second, obtain a decider DB for problem B *)

  from \<open>turing_decidable B\<close>
  have "(\<exists>D. (\<forall>nl::nat list.
           (nl \<in> B \<longrightarrow> TMC_yields_num_res D nl (1::nat))
         \<and> (nl \<notin> B \<longrightarrow> TMC_yields_num_res D nl (0::nat))
       ))"
    unfolding turing_decidable_unfolded_into_TMC_yields_conditions by auto

  then obtain DB where
    w_DB: "(\<forall>nl.
           (nl \<in> B \<longrightarrow> TMC_yields_num_res DB nl (1::nat))
         \<and> (nl \<notin> B \<longrightarrow> TMC_yields_num_res DB nl (0::nat))
       )" by blast

  (* third, define the composed machine DA = Red |+| DB that is able to decide A *)

  define DA where "DA = Red |+| DB"

  (* now, go for the main part of the proof *)
  show "turing_decidable A"
    unfolding turing_decidable_unfolded_into_TMC_yields_conditions
  proof -
    have "\<forall>nl. (nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)) \<and>
                 (nl \<notin> A \<longrightarrow> TMC_yields_num_res DA nl (0::nat))"
    proof (rule allI)
      fix nl
      show "(nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)) \<and>
              (nl \<notin> A \<longrightarrow> TMC_yields_num_res DA nl (0::nat))"
      proof
        show "nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)"
        proof
          assume "nl \<in> A"
          from \<open>nl \<in> A\<close> and w_RedTM
          obtain ml where w_ml: "composable_tm0 Red \<and> TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
            by blast
          with \<open>nl \<in> A\<close> w_DB have "TMC_yields_num_res (Red |+| DB) nl  (1::nat)"
            using TMC_yields_num_res_Hoare_plus_halt by auto
          then show "TMC_yields_num_res DA nl 1"
            using DA_def by auto
        qed
      next
        show "nl \<notin> A \<longrightarrow>  TMC_yields_num_res DA nl 0"
        proof
          assume "nl \<notin> A"
          from \<open>nl \<notin> A\<close> and w_RedTM
          obtain ml where w_ml: "composable_tm0 Red \<and> TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
            by blast
          with \<open>nl \<notin> A\<close> w_DB have "TMC_yields_num_res (Red |+| DB) nl  (0::nat)"
            using TMC_yields_num_res_Hoare_plus_halt by auto
          then show "TMC_yields_num_res DA nl 0"
            using DA_def by auto
        qed
      qed
    qed
    then show "\<exists>D. \<forall>nl. (nl \<in> A \<longrightarrow> TMC_yields_num_res D nl 1) \<and> (nl \<notin> A \<longrightarrow> TMC_yields_num_res D nl 0)"
      by auto
  qed
qed

(* The corollary about obtaining undecidability from reducibility *)

corollary turing_reducible_AB_and_non_decA_imp_non_decB:
  "\<lbrakk>turing_reducible A B; \<not> turing_decidable A \<rbrakk> \<Longrightarrow> \<not>turing_decidable B"
  using turing_reducible_AB_and_decB_imp_decA
  by blast

end


(*  Title:      FourSquares.thy
    Author:     Roelof Oosterhuis, 2007  Rijksuniversiteit Groningen
*)

section \<open>Lagrange's four-square theorem\<close>

theory FourSquares
  imports "HOL-Number_Theory.Number_Theory"
begin

context

  fixes sum4sq_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  defines "sum4sq_nat a b c d \<equiv> a^2+b^2+c^2+d^2"

  fixes is_sum4sq_nat :: "nat \<Rightarrow> bool"
  defines "is_sum4sq_nat n \<equiv> (\<exists> a b c d. n = sum4sq_nat a b c d)"

begin

(* TODO: move this lemma to the distribution (?). (It is used also in QuadForm and TwoSquares) *)
private lemma best_division_abs: "(n::int) > 0 \<Longrightarrow> \<exists> k. 2 * \<bar>a - k*n\<bar> \<le> n"
proof -
  assume a: "n > 0"
  define k where "k = a div n"
  have h: "a - k * n = a mod n" by (simp add: div_mult_mod_eq algebra_simps k_def)
  thus ?thesis
  proof (cases "2 * (a mod n) \<le> n")
    case True
    hence "2 * \<bar>a - k*n\<bar> \<le> n" using h pos_mod_sign a by auto
    thus ?thesis by blast
  next
    case False
    hence "2 * (n - a mod n) \<le> n" by auto
    have "a - (k+1)*n = a mod n - n" using h by (simp add: algebra_simps)
    hence "2 * \<bar>a - (k+1)*n\<bar> \<le> n" using h pos_mod_bound[of n a] a False by fastforce
    thus ?thesis by blast
  qed
qed

text \<open>Shows that all nonnegative integers can be written as the sum of four squares. The proof consists of the following steps:
\begin{itemize}\item For every prime $p=2n+1$ the two sets of residue classes $$\{x^2 \bmod p\mid 0\le x\le n\} ~{\rm and}~ \{-1-y^2 \bmod p \mid 0 \le y \le n\}$$ both contain $n+1$ different elements and therefore they must have at least one element in common.
\item Hence there exist $x,y$ such that $x^2+y^2+1^2+0^2$ is a multiple of $p$.
\item The next step is to show, by an infinite descent, that $p$ itself can be written as the sum of four squares.
\item Finally, using the multiplicity of this form, the same holds for all positive numbers.
\end{itemize}\<close>

private definition
  sum4sq_int :: "int \<times> int \<times> int \<times> int \<Rightarrow> int" where
  "sum4sq_int = (\<lambda>(a,b,c,d). a^2+b^2+c^2+d^2)"

private definition
  is_sum4sq_int :: "int \<Rightarrow> bool" where
  "is_sum4sq_int n \<longleftrightarrow> (\<exists> a b c d. n = sum4sq_int(a,b,c,d))"

private lemma mult_sum4sq_int: "sum4sq_int(a,b,c,d) * sum4sq_int(p,q,r,s) =
  sum4sq_int(a*p+b*q+c*r+d*s, a*q-b*p-c*s+d*r,
         a*r+b*s-c*p-d*q, a*s-b*r+c*q-d*p)"
  by (unfold sum4sq_int_def, simp add: eval_nat_numeral field_simps)

private lemma sum4sq_int_nat_eq: "sum4sq_nat a b c d = sum4sq_int (a, b, c, d)"
  unfolding sum4sq_nat_def sum4sq_int_def by simp

private lemma is_sum4sq_int_nat_eq: "is_sum4sq_nat n = is_sum4sq_int (int n)"
  unfolding is_sum4sq_nat_def is_sum4sq_int_def
proof
  assume "\<exists>a b c d. n = sum4sq_nat a b c d"
  thus "\<exists>a b c d. int n = sum4sq_int (a, b, c, d)" using sum4sq_int_nat_eq by force
next
  assume "\<exists>a b c d. int n = sum4sq_int (a, b, c, d)"
  then obtain a b c d where "int n = sum4sq_int (a, b, c, d)" by blast
  hence "int n = sum4sq_int (int (nat \<bar>a\<bar>), int (nat \<bar>b\<bar>), int (nat \<bar>c\<bar>), int (nat \<bar>d\<bar>))"
    unfolding sum4sq_int_def by simp
  hence "int n = int (sum4sq_nat (nat \<bar>a\<bar>) (nat \<bar>b\<bar>) (nat \<bar>c\<bar>) (nat \<bar>d\<bar>))"
    using sum4sq_int_nat_eq by presburger
  thus "\<exists>a b c d. n = sum4sq_nat a b c d" by auto
qed

private lemma is_mult_sum4sq_int: "is_sum4sq_int x \<Longrightarrow> is_sum4sq_int y \<Longrightarrow> is_sum4sq_int (x*y)"
  by (unfold is_sum4sq_int_def, auto simp only: mult_sum4sq_int, blast)

private lemma is_mult_sum4sq_nat: "is_sum4sq_nat x \<Longrightarrow> is_sum4sq_nat y \<Longrightarrow> is_sum4sq_nat (x*y)"
  using is_mult_sum4sq_int is_sum4sq_int_nat_eq by simp

private lemma mult_oddprime_is_sum4sq: "\<lbrakk> prime (nat p); odd p \<rbrakk> \<Longrightarrow>
  \<exists> t. 0<t \<and> t<p \<and> is_sum4sq_int (p*t)"
proof -
  assume p1: "prime (nat p)"
  then have p0: "p > 1" and "prime p"
    by (simp_all add: prime_int_nat_transfer prime_nat_iff)
  assume p2: "odd p"
  then obtain n where n: "p = 2*n+1" using oddE by blast
  with p1 have n0: "n > 0" by (auto simp add: prime_nat_iff)
  let ?C = "{0 ..< p}"
  let ?D = "{0 .. n}"
  let ?f = "%x. x^2 mod p"
  let ?g = "%x. (-1-x^2) mod p"
  let ?A = "?f ` ?D"
  let ?B = "?g ` ?D"
  have finC: "finite ?C" by simp
  have finD: "finite ?D" by simp
  from p0 have AsubC: "?A \<subseteq> ?C" and BsubC: "?B \<subseteq> ?C"
    by (auto simp add: pos_mod_conj)
  with finC have finA: "finite ?A" and finB: "finite ?B"
    by (auto simp add: finite_subset)
  from AsubC BsubC have AunBsubC: "?A \<union> ?B \<subseteq> ?C" by (rule Un_least)
  from p0 have cardC: "card ?C = nat p" using card_atLeastZeroLessThan_int by blast
  from n0 have cardD: "card ?D = 1+ nat n" by simp
  have cardA: "card ?A = card ?D"
  proof -
    have "inj_on ?f ?D"
    proof (unfold inj_on_def, auto)
      fix x fix y
      assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
        and xyp: "x^2 mod p = y^2 mod p"
      with p0 have "[x^2 = y^2] (mod p)" using cong_def by blast
      hence "p dvd x^2-y^2" using cong_iff_dvd_diff by blast
      hence "p dvd (x+y)*(x-y)" by (simp add: power2_eq_square algebra_simps)
      hence "p dvd x+y \<or> p dvd x-y" using \<open>prime p\<close> p0
        by (auto dest: prime_dvd_multD)
      moreover
      { assume "p dvd x+y"
        moreover from xn yn n have "x+y < p" by auto
        ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
        with x0 y0 have "x = y" by auto } \<comment> \<open>both are zero\<close>
      moreover
      { assume ass: "p dvd x-y"
        have "x = y"
        proof (rule ccontr, case_tac "x-y \<ge> 0")
          assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
          with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
          with xn y0 n p0 show "False" by auto
        next
          assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
          moreover from x0 yn n p0 have "y-x < p" by auto
          ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
          moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
          ultimately show "False" by auto
        qed }
      ultimately show "x=y" by auto
    qed
    with finD show ?thesis by (simp only: inj_on_iff_eq_card)
  qed
  have cardB: "card ?B = card ?D"
  proof -
    have "inj_on ?g ?D"
    proof (unfold inj_on_def, auto)
      fix x fix y
      assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
        and xyp: "(-1-x^2) mod p = (-1-y^2) mod p"
      with p0 have "[-1-y^2 = -1-x^2] (mod p)" by (simp only: cong_def)
      hence "p dvd (-1-y^2) - (-1-x^2)" by (simp only: cong_iff_dvd_diff)
      moreover have "-1-y^2 - (-1-x^2) = x^2 - y^2" by arith
      ultimately have "p dvd x^2-y^2" by simp
      hence "p dvd (x+y)*(x-y)" by (simp add: power2_eq_square algebra_simps)
      with p1 have "p dvd x+y \<or> p dvd x-y" using \<open>prime p\<close> p0
        by (auto dest: prime_dvd_multD)
      moreover
      { assume "p dvd x+y"
        moreover from xn yn n have "x+y < p" by auto
        ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
        with x0 y0 have "x = y" by auto } \<comment> \<open>both are zero\<close>
      moreover
      { assume ass: "p dvd x-y"
        have "x = y"
        proof (rule ccontr, case_tac "x-y \<ge> 0")
          assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
          with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
          with xn y0 n p0 show "False" by auto
        next
          assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
          moreover from x0 yn n p0 have "y-x < p" by auto
          ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
          moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
          ultimately show "False" by auto
        qed }
      ultimately show "x=y" by auto
    qed
    with finD show ?thesis by (simp only: inj_on_iff_eq_card)
  qed
  have "?A \<inter> ?B \<noteq> {}"
  proof (rule ccontr, auto)
    assume ABdisj: "?A \<inter> ?B = {}"
    from cardA cardB cardD have "2 + 2*(nat n) = card ?A + card ?B" by auto
    also with finA finB ABdisj have "\<dots> = card (?A \<union> ?B)"
      by (simp only: card_Un_disjoint)
    also with finC AunBsubC have "\<dots> \<le> card ?C" by (simp only: card_mono)
    also with cardC have "\<dots> = nat p" by simp
    finally have "2 + 2*(nat n) \<le> nat p" by simp
    with n show "False" by arith
  qed
  then obtain z where "z \<in> ?A \<and> z \<in> ?B" by auto
  then obtain x y where xy: "x \<in> ?D \<and> y \<in> ?D \<and> z = x^2 mod p \<and> z = (-1-y^2) mod p" by blast
  with p0 have "[x^2=-1-y^2](mod p)" by (simp add: cong_def)
  hence "p dvd x^2-(-1-y^2)" by (simp only: cong_iff_dvd_diff)
  moreover have "x^2-(-1-y^2)=x^2+y^2+1" by arith
  ultimately have "p dvd sum4sq_int(x,y,1,0)" by (auto simp add: sum4sq_int_def)
  then obtain t where t: "p * t = sum4sq_int(x,y,1,0)" by (auto simp only: dvd_def eq_refl)
  hence "is_sum4sq_int (p*t)" by (unfold is_sum4sq_int_def, auto)
  moreover have "t > 0 \<and> t < p"
  proof
    have "x^2 \<ge> 0 \<and> y^2 \<ge> 0" by simp
    hence "x^2+y^2+1 > 0" by arith
    with t have "p*t > 0" by (unfold sum4sq_int_def, auto)
    moreover
    { assume "t < 0" with p0 have "p*t < p*0" by (simp only: zmult_zless_mono2)
      hence "p*t < 0" by simp }
    moreover
    { assume "t = 0" hence "p*t = 0" by simp }
    ultimately have "\<not> t < 0 \<and> t \<noteq> 0" by auto
    thus "t > 0" by simp
    from xy have "x^2 \<le> n^2 \<and> y^2 \<le> n^2" by (auto simp add: power_mono)
    hence "x^2+y^2+1 \<le> 2*n^2 + 1" by auto
    with t have contr: "p*t \<le> 2*n^2+1" by (simp add: sum4sq_int_def)
    moreover
    { assume "t > n+1"
      with p0 have "p*(n+1) < p*t" by (simp only: zmult_zless_mono2)
      with n have "p*t > (2*n+1)*n + (2*n+1)*1" by (simp only: distrib_left)
      hence "p*t > 2*n*n + n + 2*n + 1" by (simp only: distrib_right mult_1_left)
      with n0 have "p*t > 2*n^2 + 1" by (simp add: power2_eq_square) }
    ultimately have "\<not> t > n+1" by auto
    with n0 n show "t < p" by auto
  qed
  ultimately show ?thesis by blast
qed

private lemma zprime_is_sum4sq: "prime (nat p) \<Longrightarrow> is_sum4sq_int p"
proof (cases)
  assume p2: "p=2"
  hence "p = sum4sq_int(1,1,0,0)" by (auto simp add: sum4sq_int_def)
  thus ?thesis by (auto simp add: is_sum4sq_int_def)
next
  assume "\<not> p =2" and prp: "prime (nat p)"
  hence "\<not> nat p = 2" by simp
  with prp have "2 < nat p" using prime_nat_iff by force
  moreover with prp have "odd (nat p)" using prime_odd_nat[of "nat p"] by blast
  ultimately have "odd p" by (simp add: even_nat_iff)
  with prp have "\<exists> t. 0<t \<and> t<p \<and> is_sum4sq_int (p*t)" by (rule mult_oddprime_is_sum4sq)
  then obtain a b c d t where pt_sol: "0<t \<and> t<p \<and> p*t = sum4sq_int(a,b,c,d)"
    by (unfold is_sum4sq_int_def, blast)
  hence Qt: "0<t \<and> t<p \<and> (\<exists> a1 a2 a3 a4. p*t = sum4sq_int(a1,a2,a3,a4))"
    (is "?Q t") by blast
  have "?Q 1"
  proof (rule ccontr)
    assume nQ1: "\<not> ?Q 1"
    have "\<not> ?Q t"
    proof (induct t rule: infinite_descent0_measure[where V="\<lambda>x. (nat x)- 1"], clarify)
      fix x a b c d
      assume "nat x - 1 = 0" and "x > 0" and s: "p*x=sum4sq_int(a,b,c,d)" and "x < p"
      moreover hence "x = 1" by arith
      ultimately have "?Q 1" by auto
      with nQ1 show False by auto
    next
      fix x
      assume "0 < nat x - 1" and "\<not> \<not> ?Q x"
      then obtain a1 a2 a3 a4 where ass: "1<x \<and> x<p \<and> p*x = sum4sq_int(a1,a2,a3,a4)"
        by auto
      have "\<exists> y. nat y - 1 < nat x - 1 \<and> ?Q y"
      proof (cases)
        assume evx: "even x"
        hence "even (x*p)" by simp
        with ass have ev1234: "even (a1^2+a2^2 + a3^2+a4^2)"
          by (auto simp add: sum4sq_int_def ac_simps)
        have "\<exists> b1 b2 b3 b4. p*x=sum4sq_int(b1,b2,b3,b4) \<and> even (b1+b2) \<and> even (b3+b4)"
        proof (cases)
          assume ev12: "even (a1^2+a2^2)"
          with ev1234 ass show ?thesis by auto
        next
          assume "\<not> even (a1^2+a2^2)"
          hence odd12: "odd (a1^2+a2^2)" by simp
          with ev1234 have odd34: "odd (a3^2+a4^2)" by auto
          show ?thesis
          proof (cases)
            assume ev1: "even (a1^2)"
            with odd12 have odd2: "odd (a2^2)" by simp
            show ?thesis
            proof (cases)
              assume "even (a3^2)"
              moreover from ass have "p*x = sum4sq_int(a1,a3,a2,a4)" by (auto simp add: sum4sq_int_def)
              ultimately show ?thesis using odd2 odd34 ev1 by auto
            next
              assume "\<not> even (a3^2)"
              moreover from ass have "p*x = sum4sq_int(a1,a4,a2,a3)" by (auto simp add: sum4sq_int_def)
              ultimately show ?thesis using odd34 odd2 ev1 by auto
            qed
          next
            assume odd1: "\<not> even (a1^2)"
            with odd12 have ev2: "even (a2^2)" by simp
            show ?thesis
            proof (cases)
              assume "even (a3^2)"
              moreover from ass have "sum4sq_int(a1,a4,a2,a3)=p*x" by (auto simp add: sum4sq_int_def)
              ultimately show ?thesis using odd34 odd1 ev2 by force
            next
              assume "\<not> even (a3^2)"
              moreover from ass have "sum4sq_int(a1,a3,a2,a4)=p*x" by (auto simp add: sum4sq_int_def)
              ultimately show ?thesis using odd34 odd1 ev2 by force
            qed
          qed
        qed
        then obtain b1 b2 b3 b4
          where b: "p*x = sum4sq_int(b1,b2,b3,b4) \<and> even (b1+b2) \<and> even (b3+b4)" by auto
        then obtain c1 c3 where c13: "b1+b2 = 2*c1 \<and> b3+b4 = 2*c3"
          using evenE[of "b1+b2"] evenE[of "b3+b4"] by meson
        from b have "even (b1-b2) \<and> even (b3-b4)" by simp
        then obtain c2 c4 where c24: "b1-b2 = 2*c2 \<and> b3-b4 = 2*c4"
          using evenE[of "b1-b2"] evenE[of "b3-b4"] by meson
        from evx obtain y where y: "x = 2*y" using evenE by blast
        hence "4*(p*y) = 2*(p*x)" by (simp add: ac_simps)
        also from b have "\<dots> = 2*b1^2 + 2*b2^2 + 2*b3^2 + 2*b4^2"
          by (auto simp: sum4sq_int_def)
        also have "\<dots> = (b1 + b2)^2 + (b1 - b2)^2 + (b3 + b4)^2 + (b3 - b4)^2"
          by (auto simp add: power2_eq_square algebra_simps)
        also with c13 c24 have "\<dots> = 4*(c1^2 + c2^2 + c3^2 + c4^2)"
          by (auto simp add: power_mult_distrib)
        finally have "p * y = sum4sq_int(c1,c2,c3,c4)" by (auto simp add: sum4sq_int_def)
        moreover from y ass have "0 < y \<and> y < p \<and> (nat y) - 1 < (nat x) - 1" by arith
        ultimately show ?thesis by blast
      next
        assume xodd: "\<not> even x"
        with ass have "\<exists> c1 c2 c3 c4. 2*\<bar>a1-c1*x\<bar>\<le>x \<and> 2*\<bar>a2-c2*x\<bar>\<le>x \<and> 2*\<bar>a3-c3*x\<bar>\<le>x \<and> 2*\<bar>a4-c4*x\<bar>\<le>x"
          by (simp add: best_division_abs)
        then obtain b1 c1 b2 c2 b3 c3 b4 c4 where
          bc_def: "b1 = a1-c1*x \<and> b2 = a2-c2*x \<and> b3 = a3-c3*x \<and> b4 = a4-c4*x"
          and "2*\<bar>b1\<bar>\<le>x \<and> 2*\<bar>b2\<bar>\<le>x \<and> 2*\<bar>b3\<bar>\<le>x \<and> 2*\<bar>b4\<bar>\<le>x"
          by blast
        moreover have "2*\<bar>b1\<bar>\<noteq>x \<and> 2*\<bar>b2\<bar>\<noteq>x \<and> 2*\<bar>b3\<bar>\<noteq>x \<and> 2*\<bar>b4\<bar>\<noteq>x" using xodd by fastforce
        ultimately have bc_abs: "2*\<bar>b1\<bar><x \<and> 2*\<bar>b2\<bar><x \<and> 2*\<bar>b3\<bar><x \<and> 2*\<bar>b4\<bar><x" by auto
        let ?B = "b1^2 + b2^2 + b3^2 + b4^2"
        let ?C = "c1^2 + c2^2 + c3^2 + c4^2"
        have "x dvd ?B"
        proof
          from bc_def ass have
            "?B = p*x - 2*(a1*c1+a2*c2+a3*c3+a4*c4)*x + ?C*x^2"
            unfolding sum4sq_int_def by (auto simp add: power2_eq_square algebra_simps)
          thus "?B = x*(p - 2*(a1*c1+a2*c2+a3*c3+a4*c4) + ?C*x)"
            by (auto simp add: ac_simps power2_eq_square
              distrib_left right_diff_distrib)
        qed
        then obtain y where y: "?B = x * y" by (auto simp add: dvd_def)
        let ?A1 = "a1*b1 + a2*b2 + a3*b3 + a4*b4"
        let ?A2 = "a1*b2 - a2*b1 - a3*b4 + a4*b3"
        let ?A3 = "a1*b3 + a2*b4 - a3*b1 - a4*b2"
        let ?A4 = "a1*b4 - a2*b3 + a3*b2 - a4*b1"
        let ?A = "sum4sq_int(?A1,?A2,?A3,?A4)"
        have "x dvd ?A1 \<and> x dvd ?A2 \<and> x dvd ?A3 \<and> x dvd ?A4"
        proof (safe)
          from bc_def have
            "?A1 = (b1+c1*x)*b1 + (b2+c2*x)*b2 + (b3+c3*x)*b3 + (b4+c4*x)*b4"
            by simp
          also with y have "\<dots> = x*(y + c1*b1 + c2*b2 + c3*b3 + c4*b4)"
            by (auto simp add: distrib_left power2_eq_square ac_simps)
          finally show "x dvd ?A1" by auto
          from bc_def have
            "?A2 = (b1+c1*x)*b2 - (b2+c2*x)*b1 - (b3+c3*x)*b4 + (b4+c4*x)*b3"
            by simp
          also have "\<dots> = x*(c1*b2 - c2*b1 - c3*b4 + c4*b3)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A2" by auto
          from bc_def have
            "?A3 = (b1+c1*x)*b3 + (b2+c2*x)*b4 - (b3+c3*x)*b1 - (b4+c4*x)*b2"
            by simp
          also have "\<dots> = x*(c1*b3 + c2*b4 - c3*b1 - c4*b2)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A3" by auto
          from bc_def have
            "?A4 = (b1+c1*x)*b4 - (b2+c2*x)*b3 + (b3+c3*x)*b2 - (b4+c4*x)*b1"
            by simp
          also have "\<dots> = x*(c1*b4 - c2*b3 + c3*b2 - c4*b1)"
            by (auto simp add: distrib_left right_diff_distrib ac_simps)
          finally show "x dvd ?A4" by auto
        qed
        then obtain d1 d2 d3 d4 where d:
          "?A1=x*d1 \<and> ?A2=x*d2 \<and> ?A3=x*d3 \<and> ?A4=x*d4"
          by (auto simp add: dvd_def)
        let ?D = "sum4sq_int(d1,d2,d3,d4)"
        from d have "x^2*?D = ?A"
          by (auto simp only: sum4sq_int_def power_mult_distrib distrib_left)
        also have "\<dots> = sum4sq_int(a1,a2,a3,a4)*sum4sq_int(b1,b2,b3,b4)"
          by (simp only: mult_sum4sq_int)
        also with y ass have "\<dots> = (p*x)*(x*y)" by (auto simp add: sum4sq_int_def)
        also have "\<dots> = x^2*(p*y)" by (simp only: power2_eq_square ac_simps)
        finally have "x^2*(?D - p*y) = 0" by (auto simp add: right_diff_distrib)
        with ass have "p*y = ?D" by auto
        moreover have y_l_x: "y < x"
        proof -
          have "4*b1^2 = (2*\<bar>b1\<bar>)^2 \<and> 4*b2^2 = (2*\<bar>b2\<bar>)^2 \<and>
            4*b3^2 = (2*\<bar>b3\<bar>)^2 \<and> 4*b4^2 = (2*\<bar>b4\<bar>)^2" by simp
          with bc_abs have "4*b1^2<x^2 \<and> 4*b2^2<x^2 \<and> 4*b3^2<x^2 \<and> 4*b4^2<x^2"
            using power_strict_mono [of "2*\<bar>b\<bar>" x 2 for b]
            by auto
          hence "?B < x^2" by auto
          with y have "x*(x-y) > 0"
            by (auto simp add: power2_eq_square right_diff_distrib)
          moreover from ass have "x > 0" by simp
          ultimately show ?thesis using zero_less_mult_pos by fastforce
        qed
        moreover have "y > 0"
        proof -
          have b2pos: "b1^2 \<ge> 0 \<and> b2^2 \<ge> 0 \<and> b3^2 \<ge> 0 \<and> b4^2 \<ge> 0" by simp
          hence "?B = 0 \<or> ?B > 0" by arith
          moreover
          { assume "?B = 0"
            moreover from b2pos have
              "?B-b1^2 \<ge> 0 \<and> ?B-b2^2 \<ge> 0 \<and> ?B-b3^2 \<ge> 0 \<and> ?B-b4^2 \<ge> 0" by arith
            ultimately have "b1^2 \<le> 0 \<and> b2^2 \<le> 0 \<and> b3^2 \<le> 0 \<and> b4^2 \<le> 0" by auto
            with b2pos have  "b1^2 = 0 \<and> b2^2 = 0 \<and> b3^2 = 0 \<and> b4^2 = 0" by arith
            hence "b1 = 0 \<and> b2 = 0 \<and> b3 = 0 \<and> b4 = 0" by auto
            with bc_def have "x dvd a1 \<and> x dvd a2 \<and> x dvd a3 \<and> x dvd a4"
              by auto
            hence "x^2 dvd a1^2 \<and> x^2 dvd a2^2 \<and> x^2 dvd a3^2 \<and> x^2 dvd a4^2" by simp
            hence "x^2 dvd a1^2+a2^2+a3^2+a4^2" by (simp only: dvd_add)
            with ass have "x^2 dvd p*x" by (auto simp only: sum4sq_int_def)
            hence "x*x dvd x*p" by (simp only: power2_eq_square ac_simps)
            with ass have "nat x dvd nat p"
              by (simp add: nat_dvd_iff)
            moreover from ass prp have "x \<ge> 0 \<and> x \<noteq> 1 \<and> x \<noteq> p \<and> prime (nat p)" by simp
            ultimately have "False" unfolding prime_nat_iff by auto }
          moreover
          { assume "?B > 0"
            with y have "x*y > 0" by simp
            moreover from ass have "x > 0" by simp
            ultimately have ?thesis using zero_less_mult_pos by blast }
          ultimately show ?thesis by auto
        qed
        moreover with y_l_x have "(nat y) - 1 < (nat x) - 1" by arith
        moreover from y_l_x ass have "y < p" by auto
        ultimately show ?thesis by blast
      qed
      thus "\<exists> y. nat y - 1 < nat x - 1 \<and> \<not> \<not> ?Q y" by blast
    qed
    with Qt show "False" by simp
  qed
  thus "is_sum4sq_int p" by (auto simp add: is_sum4sq_int_def)
qed

private lemma prime_is_sum4sq: "prime p \<Longrightarrow> is_sum4sq_nat p"
  using zprime_is_sum4sq is_sum4sq_int_nat_eq by simp

theorem sum_of_four_squares: "is_sum4sq_nat n"
proof (induction n rule: nat_less_induct)
case (1 n)
  show ?case
  proof (cases "n>1")
  case False
    hence "n = 0 \<or> n = 1" by auto
    moreover have "0 = sum4sq_nat 0 0 0 0" "1 = sum4sq_nat 1 0 0 0" unfolding sum4sq_nat_def by auto
    ultimately show ?thesis unfolding is_sum4sq_nat_def by blast
  next
  case True
    then obtain p m where dec: "prime p \<and> n = p * m" using prime_factor_nat[of n]
      by (auto elim: dvdE)
    moreover hence "m<n" using n_less_m_mult_n[of m p] prime_gt_Suc_0_nat[of p] True by linarith
    ultimately have "is_sum4sq_nat m" "is_sum4sq_nat p" using 1 prime_is_sum4sq by blast+
    thus ?thesis using dec is_mult_sum4sq_nat by blast
  qed
qed

end

end


theory sort_MSortBU2IsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun risers :: "int list => (int list) list" where
"risers (Nil2) = Nil2"
| "risers (Cons2 y (Nil2)) = Cons2 (Cons2 y (Nil2)) (Nil2)"
| "risers (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case risers (Cons2 y2 xs) of
            Nil2 => risers (Cons2 y2 xs)
          | Cons2 ys yss => Cons2 (Cons2 y ys) yss
      else
        Cons2 (Cons2 y (Nil2)) (risers (Cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (Nil2) = Nil2"
| "pairwise (Cons2 xs (Nil2)) = Cons2 xs (Nil2)"
| "pairwise (Cons2 xs (Cons2 ys xss)) =
     Cons2 (lmerge xs ys) (pairwise xss)"

fun mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (Nil2) = Nil2"
| "mergingbu2 (Cons2 xs (Nil2)) = xs"
| "mergingbu2 (Cons2 xs (Cons2 z x2)) =
     mergingbu2 (pairwise (Cons2 xs (Cons2 z x2)))"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun msortbu2 :: "int list => int list" where
"msortbu2 x =
   dot
     (% (y :: (int list) list) => mergingbu2 y)
     (% (z :: int list) => risers z) x"

(*hipster risers
          lmerge
          pairwise
          mergingbu2
          insert2
          isort
          dot
          msortbu2 *)

theorem x0 :
  "!! (x :: int list) . (msortbu2 x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end