(* Title: Dual_Systems.thy
   Author: Chelsea Edmonds
*)

section \<open> Dual Systems \<close>
text \<open>The concept of a dual incidence system \<^cite>\<open>"colbournHandbookCombinatorialDesigns2007"\<close>
 is an important property in design theory. It enables us to reason on the existence of several
different types of design constructs through dual properties \<^cite>\<open>"stinsonCombinatorialDesignsConstructions2004"\<close>\<close>

theory Dual_Systems imports Incidence_Matrices
begin

subsection \<open>Dual Blocks \<close>
text \<open>A dual design of $(\mathcal{V}, \mathcal{B})$, is the design where each block in $\mathcal{B}$
represents a point $x$, and a block in a dual design is a set of blocks which $x$ is in from the original design.
It is important to note that if a block repeats in $\mathcal{B}$, each instance of the block is a distinct point.
As such the definition below uses each block's list index as its identifier. The list of points would simply be the
indices $0..<$length $Bs$ \<close>

definition dual_blocks :: "'a set \<Rightarrow> 'a set list \<Rightarrow> nat set multiset" where
"dual_blocks \<V> \<B>s \<equiv> {# {y . y < length \<B>s \<and> x \<in> \<B>s ! y} . x \<in># (mset_set \<V>)#}"

lemma dual_blocks_wf: "b \<in># dual_blocks V Bs \<Longrightarrow> b \<subseteq> {0..<length Bs}"
  by (auto simp add: dual_blocks_def)

context ordered_incidence_system
begin

definition dual_blocks_ordered :: "nat set list" ("\<B>s*") where
"dual_blocks_ordered \<equiv> map (\<lambda> x . {y . y < length \<B>s \<and> x \<in> \<B>s ! y}) \<V>s"

lemma dual_blocks_ordered_eq: "dual_blocks \<V> \<B>s= mset (\<B>s*)"
  by (auto simp add: distinct dual_blocks_def dual_blocks_ordered_def mset_set_set)

lemma dual_blocks_len: "length \<B>s* = length \<V>s"
  by (simp add: dual_blocks_ordered_def)

text \<open>A dual system is an incidence system \<close>
sublocale dual_sys: finite_incidence_system "{0..<length \<B>s}" "dual_blocks \<V> \<B>s"
  using dual_blocks_wf by(unfold_locales) (auto)

lemma dual_is_ordered_inc_sys: "ordered_incidence_system [0..<length \<B>s] \<B>s*"
  using inc_sys_orderedI dual_blocks_ordered_eq
  by (metis atLeastLessThan_upt distinct_upt dual_sys.incidence_system_axioms)

interpretation ordered_dual_sys: ordered_incidence_system "[0..<length \<B>s]" "\<B>s*"
  using dual_is_ordered_inc_sys by simp

subsection \<open>Basic Dual Properties\<close>
lemma ord_dual_blocks_b: "ordered_dual_sys.\<b> = \<v>"
  using dual_blocks_len by (simp add: points_list_length)

lemma dual_blocks_b: "dual_sys.\<b> = \<v>"
  using points_list_length
  by (simp add: dual_blocks_len dual_blocks_ordered_eq)

lemma dual_blocks_v: "dual_sys.\<v> = \<b>"
  by fastforce

lemma ord_dual_blocks_v: "ordered_dual_sys.\<v> = \<b>"
  by fastforce

lemma dual_point_block: "i < \<v> \<Longrightarrow> \<B>s* ! i = {y. y < length \<B>s \<and> (\<V>s ! i) \<in> \<B>s ! y}"
  by (simp add: dual_blocks_ordered_def points_list_length)

lemma dual_incidence_iff: "i < \<v> \<Longrightarrow> j < \<b> \<Longrightarrow> \<B>s ! j = bl \<Longrightarrow> \<V>s ! i = x \<Longrightarrow> (x \<in> bl \<longleftrightarrow> j \<in> \<B>s* ! i)"
  using dual_point_block by (intro iffI)(simp_all)

lemma dual_incidence_iff2: "i < \<v> \<Longrightarrow> j < \<b> \<Longrightarrow> (\<V>s ! i \<in> \<B>s ! j  \<longleftrightarrow> j \<in> \<B>s* ! i)"
  using dual_incidence_iff by simp

lemma dual_blocks_point_exists: "bl \<in># dual_blocks \<V> \<B>s \<Longrightarrow>
    \<exists> x. x \<in> \<V> \<and> bl = {y . y < length \<B>s \<and> x \<in> \<B>s ! y}"
  by (auto simp add: dual_blocks_def)

lemma dual_blocks_ne_index_ne:  "j1 < length \<B>s* \<Longrightarrow> j2 < length \<B>s* \<Longrightarrow> \<B>s* ! j1 \<noteq> \<B>s* ! j2 \<Longrightarrow> j1 \<noteq> j2"
  by auto

lemma dual_blocks_list_index_img: "image_mset (\<lambda>x . \<B>s* ! x) (mset_set {0..<length \<B>s*}) = mset \<B>s*"
  using lessThan_atLeast0 ordered_dual_sys.blocks_list_length ordered_dual_sys.blocks_mset_image
  by presburger

lemma dual_blocks_elem_iff:
  assumes "j < \<v>"
  shows "x \<in> (\<B>s* ! j) \<longleftrightarrow> \<V>s ! j \<in> \<B>s ! x \<and> x < \<b>"
proof (intro iffI conjI)
  show "x \<in> \<B>s* ! j \<Longrightarrow> \<V>s ! j \<in> \<B>s ! x"
    using assms ordered_incidence_system.dual_point_block ordered_incidence_system_axioms
    by fastforce
  show "x \<in> \<B>s* ! j \<Longrightarrow> x < \<b>"
    using assms dual_blocks_ordered_def dual_point_block by fastforce
  show "\<V>s ! j \<in> \<B>s ! x \<and> x < \<b> \<Longrightarrow> x \<in> \<B>s* ! j"
    by (metis (full_types) assms blocks_list_length dual_incidence_iff)
qed

text \<open>The incidence matrix of the dual of a design is just the transpose \<close>
lemma dual_incidence_mat_eq_trans: "ordered_dual_sys.N = N\<^sup>T"
proof (intro eq_matI)
  show dimr: "dim_row ordered_dual_sys.N = dim_row N\<^sup>T" using dual_blocks_v by (simp)
  show dimc: "dim_col ordered_dual_sys.N = dim_col N\<^sup>T" using ord_dual_blocks_b by (simp)
  show "\<And>i j. i < dim_row N\<^sup>T \<Longrightarrow> j < dim_col N\<^sup>T \<Longrightarrow> ordered_dual_sys.N $$ (i, j) = N\<^sup>T $$ (i, j)"
  proof -
    fix i j assume ilt: "i < dim_row N\<^sup>T" assume jlt: "j < dim_col N\<^sup>T"
    then have ilt2: "i < length \<B>s"using dimr
      using blocks_list_length ord_dual_blocks_v ilt ordered_dual_sys.dim_row_is_v by linarith
    then have ilt3: "i < \<b>" by simp
    have jlt2: "j < \<v>" using jlt
      using dim_row_is_v by fastforce
    have "ordered_dual_sys.N $$ (i, j) =  (if ([0..<length \<B>s] ! i) \<in> (\<B>s* ! j) then 1 else 0)"
      using dimr dual_blocks_len ilt jlt inc_matrix_elems_one_zero
      by (metis  inc_mat_dim_row inc_matrix_point_in_block_iff index_transpose_mat(3) )
    then have "ordered_dual_sys.N $$ (i, j) = (if \<V>s ! j \<in> \<B>s ! i then 1 else 0)"
      using ilt3 jlt2 dual_incidence_iff2 by simp
    thus "ordered_dual_sys.N $$ (i, j) = N\<^sup>T $$ (i, j)"
      using ilt3 jlt2 dim_row_is_v dim_col_is_b N_trans_index_val by simp
  qed
qed

lemma dual_incidence_mat_eq_trans_rev: "(ordered_dual_sys.N)\<^sup>T = N"
  using dual_incidence_mat_eq_trans by simp

subsection \<open>Incidence System Dual Properties\<close>
text \<open>Many common design properties have a dual in the dual design which enables extensive reasoning
Using incidence matrices and the transpose property these are easy to prove. We leave examples of
counting proofs (commented out), to demonstrate how incidence matrices can significantly simplify
reasoning \<close>

lemma dual_blocks_nempty:
  assumes "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)"
  assumes "bl \<in># dual_blocks \<V> \<B>s"
  shows "bl \<noteq> {}"
proof -
  have "bl \<in># {# {y . y < length \<B>s \<and> x \<in> \<B>s ! y} . x \<in># (mset_set \<V>)#}"
    using assms dual_blocks_def by metis
  then obtain x where "x \<in># (mset_set \<V>)" and blval: "bl = {y . y < length \<B>s \<and> x \<in> \<B>s ! y}"
    by blast
  then obtain bl' where "bl' \<in># \<B>" and xin: "x \<in> bl'" using assms(1)
    using point_in_block_rep_min_iff by auto
  then obtain y where "y < length \<B>s" and "\<B>s ! y = bl'"
    using valid_blocks_index_cons by auto
  then have "y \<in> bl"
    by (simp add: xin blval)
  thus ?thesis by blast
qed

lemma dual_blocks_size_is_rep: "j < length \<B>s* \<Longrightarrow> card (\<B>s* ! j) = \<B> rep (\<V>s ! j)"
  using dual_incidence_mat_eq_trans trans_mat_rep_block_size_sym(2)
  by (metis dual_blocks_len dual_is_ordered_inc_sys inc_mat_dim_row mat_rep_num_N_row
      ordered_incidence_system.mat_block_size_N_col points_list_length size_mset)

(* Old Counting proof
proof -
  have 1: "card (\<B>s* ! j) = card {y . y < length \<B>s \<and> (\<V>s ! j) \<in> \<B>s ! y}"
    using assms dual_blocks_len dual_point_block points_list_length by force
  also have 2: "... = card {y \<in> {0..<length \<B>s} . (\<V>s ! j) \<in> \<B>s ! y}" by simp
  also have "... = size (mset_set {y \<in> {0..<length \<B>s} . (\<V>s ! j) \<in> \<B>s ! y})" by simp
  also have "... = size {# y \<in># mset_set {0..< length \<B>s} . (\<V>s ! j) \<in> \<B>s ! y #}"
    using filter_mset_mset_set by simp
  finally have "card (\<B>s* ! j) = size {# bl \<in># \<B> . (\<V>s ! j) \<in> bl #}"
    by (metis 1 2 filter_size_blocks_eq_card_indexes lessThan_atLeast0 size_mset)
  thus ?thesis by (simp add: point_replication_number_def)
qed
*)

lemma dual_blocks_size_is_rep_obtain:
  assumes "bl \<in># dual_blocks \<V> \<B>s"
  obtains x where "x \<in> \<V>" and "card bl = \<B> rep x"
proof -
  obtain j where jlt1: "j < length \<B>s*" and bleq: "\<B>s* ! j = bl"
    by (metis assms dual_blocks_ordered_eq in_mset_conv_nth)
  then have jlt: "j < \<v>"
    by (simp add: dual_blocks_len points_list_length)
  let ?x = "\<V>s ! j"
  have xin: "?x \<in> \<V>" using jlt
    by (simp add: valid_points_index)
  have "card bl = \<B> rep ?x" using dual_blocks_size_is_rep jlt1 bleq by auto
  thus ?thesis using xin that by auto
qed

lemma dual_blocks_rep_is_size:
  assumes "i < length \<B>s"
  shows "(mset \<B>s*) rep i = card (\<B>s ! i)"
proof -
  have "[0..<length \<B>s] ! i = i" using assms by simp
  then have "(mset \<B>s*) rep i = mat_rep_num ordered_dual_sys.N i"
    using ordered_dual_sys.mat_rep_num_N_row assms length_upt minus_nat.diff_0
      ordered_dual_sys.points_list_length by presburger
  also have "... = mat_block_size (ordered_dual_sys.N)\<^sup>T i" using dual_incidence_mat_eq_trans
    trans_mat_rep_block_size_sym(2) by (metis assms inc_mat_dim_col index_transpose_mat(2))
  finally show ?thesis using dual_incidence_mat_eq_trans_rev
    by (metis assms blocks_list_length mat_block_size_N_col)
qed

(* Counting Proof
proof -
  have "(mset \<B>s* ) rep i = size {# bl \<in># (mset \<B>s* ) . i \<in> bl #}"
    by (simp add: point_replication_number_def)
  also have 1: "... = size {# bl \<in># {# {y . y < length \<B>s \<and> x \<in> \<B>s ! y} . x \<in># (mset_set \<V>)#} . i \<in> bl #}"
    using dual_blocks_ordered_eq dual_blocks_def by metis
  also have "... = size (filter_mset (\<lambda> bl . i \<in> bl)
      (image_mset (\<lambda> x . {y . y < length \<B>s \<and> x \<in> \<B>s ! y}) (mset_set \<V>)))" by simp
  finally have "(mset \<B>s* ) rep i = size (image_mset (\<lambda> x . {y . y < length \<B>s \<and> x \<in> \<B>s ! y})
      (filter_mset (\<lambda> bl . i \<in> {y . y < length \<B>s \<and> bl \<in> \<B>s ! y}) (mset_set \<V>)))"
    using filter_mset_image_mset by (metis 1 ordered_dual_sys.point_rep_number_alt_def)
  then have "(mset \<B>s* ) rep i = size (filter_mset (\<lambda> bl . i \<in> {y . y < length \<B>s \<and> bl \<in> \<B>s ! y})
      (mset_set \<V>))"
    by fastforce
  then have "(mset \<B>s* ) rep i = size (filter_mset (\<lambda> bl . bl \<in> \<B>s ! i) (mset_set \<V>))"
    using assms by simp
  then have "(mset \<B>s* ) rep i =  card {x \<in> \<V> . x \<in> (\<B>s ! i)}" by simp
  thus ?thesis using assms block_size_alt by auto
qed
*)

lemma dual_blocks_inter_index:
  assumes "j1 < length \<B>s*" "j2 < length \<B>s*"
  shows "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = points_index \<B> {\<V>s ! j1, \<V>s ! j2}"
proof -
  have assms2: "j1 < \<v>" "j2 < \<v>" using assms
    by (simp_all add: dual_blocks_len points_list_length)
  have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = mat_inter_num (ordered_dual_sys.N) j1 j2"
    by (simp add: assms(1) assms(2) ordered_dual_sys.mat_inter_num_conv)
  also have "... = mat_point_index N {j1, j2}" using dual_incidence_mat_eq_trans_rev trans_mat_point_index_inter_sym(2)
    by (metis assms inc_mat_dim_col)
  finally show ?thesis using assms2 incidence_mat_two_index
    by presburger
qed
(* Counting Proof
  have fin: "finite {0..<length \<B>s}"
    by auto
  have j1lt: "j1 < \<v>" using assms
    using dual_blocks_len points_list_length by auto
  have j2lt: "j2 < \<v>" using assms dual_blocks_len points_list_length by auto
  have iff: "\<And> x. (x \<in>(\<B>s* ! j1) \<and> x \<in> (\<B>s* ! j2)) \<longleftrightarrow> (\<V>s ! j1 \<in> \<B>s ! x \<and> x < \<b> \<and> \<V>s ! j2 \<in> \<B>s ! x)"
    by (auto simp add: dual_blocks_elem_iff j1lt j2lt)
  have pi: "points_index \<B> {\<V>s ! j1, \<V>s ! j2} = size {# bl \<in># \<B> . \<V>s !j1 \<in> bl \<and> \<V>s ! j2 \<in> bl#}"
    by (auto simp add: points_index_def)
  have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = card ({x . x <length \<B>s \<and> x \<in> (\<B>s* ! j1) \<and> x \<in> (\<B>s* ! j2)})"
    apply (auto simp add: intersection_number_def)
    by (smt (verit) Collect_cong Int_Collect blocks_list_length dual_blocks_elem_iff inf.idem inf_set_def j2lt mem_Collect_eq)
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = card ({x . x <length \<B>s \<and> \<V>s ! j1 \<in> \<B>s ! x \<and> \<V>s ! j2 \<in> \<B>s ! x})" using iff
    size_mset by (smt (verit, best) Collect_cong)
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size (mset_set {x \<in> {0..<length \<B>s}. \<V>s ! j1 \<in> \<B>s ! x \<and> \<V>s ! j2 \<in> \<B>s ! x})" by simp
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size ({#x \<in># mset_set {0..<length \<B>s}. \<V>s ! j1 \<in> \<B>s ! x \<and> \<V>s ! j2 \<in> \<B>s ! x#})" using fin by simp
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size (filter_mset (\<lambda> x . \<V>s ! j1 \<in> \<B>s ! x \<and> \<V>s ! j2 \<in> \<B>s ! x) (mset_set {0..<length \<B>s}))" by simp
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size (image_mset (\<lambda> i. \<B>s ! i) (filter_mset (\<lambda> x . \<V>s ! j1 \<in> \<B>s ! x \<and> \<V>s ! j2 \<in> \<B>s ! x) (mset_set {0..<length \<B>s})))"
    by simp
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size (filter_mset (\<lambda> x . \<V>s ! j1 \<in> x \<and> \<V>s ! j2 \<in> x) (image_mset (\<lambda> i. \<B>s ! i) (mset_set {0..<length \<B>s})))"
    by (simp add: filter_mset_image_mset)
  then have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = size {# bl \<in># \<B> . \<V>s !j1 \<in> bl \<and> \<V>s ! j2 \<in> bl#}"
    by (metis blocks_list_length blocks_mset_image lessThan_atLeast0)
  thus ?thesis using pi by simp
qed
*)

lemma dual_blocks_points_index_inter:
  assumes "i1 < \<b>" "i2 < \<b>"
  shows "(mset \<B>s*) index {i1, i2} = (\<B>s ! i1) |\<inter>| (\<B>s ! i2)"
proof -
  have "(mset \<B>s*) index {i1, i2} = mat_point_index (ordered_dual_sys.N) {i1, i2}"
    using assms(1) assms(2) blocks_list_length ord_dual_blocks_v ordered_dual_sys.dim_row_is_v
      ordered_dual_sys.incidence_mat_two_index ordered_dual_sys.mat_ord_inc_sys_point by presburger
  also have "... = mat_inter_num N i1 i2" using dual_incidence_mat_eq_trans trans_mat_point_index_inter_sym(1)
    by (metis assms(1) assms(2) dual_incidence_mat_eq_trans_rev ord_dual_blocks_v ordered_dual_sys.dim_row_is_v)
  finally show ?thesis using mat_inter_num_conv
    using assms(1) assms(2) by auto
qed

(* Counting Proof
proof -
  have "\<And> j . j \<in># mset_set {0..<length \<B>s*} \<Longrightarrow> j < \<v>"
    by (metis atLeastLessThan_iff atLeastLessThan_upt dual_blocks_len mset_upt points_list_length set_mset_mset)
  then have iff: "\<And> j i. j \<in># mset_set {0..<length \<B>s*} \<Longrightarrow> i < \<b> \<Longrightarrow> i \<in> (\<B>s* ! j) \<longleftrightarrow> (\<V>s ! j) \<in> (\<B>s ! i)"
    using assms dual_incidence_iff2 by simp
  then have iff2: "\<And> j . j \<in># mset_set {0..<length \<B>s*} \<Longrightarrow> i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j) \<longleftrightarrow> (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)"
    using assms by auto
  have ss2: "(\<B>s ! i2) \<subseteq> \<V>" using wellformed assms by auto
  then have ss: "{x . x \<in> (\<B>s ! i1) \<and> x \<in> (\<B>s ! i2)} \<subseteq> \<V>"
    by auto
  then have inter:  "(\<B>s ! i1) |\<inter>| (\<B>s ! i2) = card {x \<in> \<V>. x \<in> (\<B>s ! i1) \<and> x \<in> (\<B>s ! i2)}"
    using intersection_number_def by (metis Collect_conj_eq Collect_mem_eq Int_absorb1)
  have inj: "inj_on (\<lambda> j. \<V>s ! j) {j \<in> {0..<length \<V>s} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)}"
    by (simp add: inj_on_nth distinct)
  have init: "(mset \<B>s* ) index {i1, i2} = size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#}"
    by (simp add: points_index_def)
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} = size {#j \<in># mset_set {0..<length \<B>s*} . i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j)#}"
  proof -
    have "size {#j \<in># mset_set {0..<length \<B>s*} . i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j)#}
      = size (filter_mset (\<lambda> j. i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j)) (mset_set {0..<length \<B>s*})) " by simp
    also have s1: "... = size (image_mset (\<lambda>x . \<B>s* ! x) (filter_mset (\<lambda> j. i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j)) (mset_set {0..<length \<B>s*})))" by fastforce
    also have s2: "... = size (filter_mset (\<lambda> j. i1 \<in> j \<and> i2 \<in> j) (image_mset (\<lambda>x . \<B>s* ! x) (mset_set {0..<length \<B>s*})))"
      by (simp add: filter_mset_image_mset)
    finally have "size {#j \<in># mset_set {0..<length \<B>s*} . i1 \<in> (\<B>s* ! j) \<and> i2 \<in> (\<B>s* ! j)#} = size (filter_mset (\<lambda> j. i1 \<in> j \<and> i2 \<in> j) (mset \<B>s* ))"
      using dual_blocks_list_index_img s2 s1 by presburger
    thus ?thesis by simp
  qed
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} = size {#j \<in># mset_set {0..<length \<B>s*} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)#}" using iff2
    by (smt (verit, ccfv_SIG) filter_mset_cong)
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} =
    card ({j \<in> {0..<length \<B>s*} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)})" by simp
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} =
    card ({j \<in> {0..<length \<V>s} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)})" using dual_blocks_len by presburger
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} =
    card (image (\<lambda> j. \<V>s ! j) {j \<in> {0..<length \<V>s} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)})"
    using inj card_image[of "(\<lambda> j. \<V>s ! j)" "{j \<in> {0..<length \<V>s} . (\<V>s ! j) \<in> (\<B>s ! i1) \<and> (\<V>s ! j) \<in> (\<B>s ! i2)}"] by simp
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} =
    card {j \<in> image (\<lambda> j. \<V>s ! j) {0..<length \<V>s}. j \<in> (\<B>s ! i1) \<and> j \<in> (\<B>s ! i2)}"
    using Compr_image_eq[of "(\<lambda> j. \<V>s ! j)" "{0..<length \<V>s}" "(\<lambda> j . j \<in> (\<B>s ! i1) \<and> j \<in> (\<B>s ! i2))"] by simp
  then have "size {#bl \<in># (mset \<B>s* ) . i1 \<in> bl \<and> i2 \<in> bl#} =
    card {j \<in> \<V>. j \<in> (\<B>s ! i1) \<and> j \<in> (\<B>s ! i2)}"
    using lessThan_atLeast0 points_list_length points_set_index_img by presburger
  thus ?thesis using init inter by simp
qed*)
end

subsection \<open>Dual Properties for Design sub types \<close>
context ordered_design
begin

lemma dual_is_design:
  assumes "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)" \<comment> \<open> Required to ensure no blocks are empty \<close>
  shows "design {0..<length \<B>s} (dual_blocks \<V> \<B>s)"
  using dual_blocks_nempty assms by (unfold_locales) (simp)
end

context ordered_proper_design
begin

lemma dual_sys_b_non_zero: "dual_sys.\<b> \<noteq> 0"
  using v_non_zero dual_blocks_b by auto

lemma dual_is_proper_design:
  assumes "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)"  \<comment> \<open> Required to ensure no blocks are empty \<close>
  shows "proper_design {0..<length \<B>s} (dual_blocks \<V> \<B>s)"
  using dual_blocks_nempty dual_sys_b_non_zero assms by (unfold_locales) (simp_all)

end

context ordered_block_design
begin

lemma dual_blocks_const_rep: "i \<in> {0..<length \<B>s} \<Longrightarrow> (mset \<B>s*) rep i = \<k>"
  using dual_blocks_rep_is_size uniform by (metis atLeastLessThan_iff nth_mem_mset)

lemma dual_blocks_constant_rep_design:
  assumes "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)"
  shows "constant_rep_design {0..<length \<B>s} (dual_blocks \<V> \<B>s) \<k>"
proof -
  interpret des: proper_design "{0..<length \<B>s}" "(dual_blocks \<V> \<B>s)"
    using dual_is_proper_design assms by simp
  show ?thesis using dual_blocks_const_rep dual_blocks_ordered_eq by (unfold_locales) (simp)
qed

end

context ordered_constant_rep
begin

lemma dual_blocks_const_size:  "j < length \<B>s* \<Longrightarrow> card (\<B>s* ! j) = \<r>"
  using dual_blocks_rep_is_size dual_blocks_len dual_blocks_size_is_rep by fastforce

lemma dual_is_block_design: "block_design {0..<length \<B>s} (dual_blocks \<V> \<B>s) \<r>"
proof -
  have "\<r> > 0" by (simp add: r_gzero)
  then have "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)" using rep_number by simp
  then interpret pdes: proper_design "{0..<length \<B>s}" "(dual_blocks \<V> \<B>s)"
    using dual_is_proper_design by simp
  have "\<And> bl. bl \<in># dual_blocks \<V> \<B>s \<Longrightarrow> card bl = \<r>"
    using dual_blocks_const_size
    by (metis dual_blocks_ordered_eq in_set_conv_nth set_mset_mset)
  thus ?thesis by (unfold_locales) (simp)
qed

end

context ordered_pairwise_balance
begin

lemma dual_blocks_const_intersect:
  assumes "j1 < length \<B>s*" "j2 < length \<B>s*"
  assumes "j1 \<noteq> j2"
  shows "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = \<Lambda>"
proof -
  have "\<V>s ! j1 \<noteq> \<V>s ! j2" using assms(3)
    using assms(1) assms(2) distinct dual_blocks_len nth_eq_iff_index_eq by auto
  then have c: "card {\<V>s ! j1, \<V>s ! j2} = 2"
    using card_2_iff by blast
  have ss: "{\<V>s ! j1, \<V>s ! j2} \<subseteq> \<V>" using assms points_list_length
    using dual_blocks_len by auto
  have "(\<B>s* ! j1) |\<inter>| (\<B>s* ! j2) = points_index \<B> {\<V>s ! j1, \<V>s ! j2}"
    using dual_blocks_inter_index assms by simp
  thus ?thesis using ss c balanced
    by blast
qed

lemma dual_is_const_intersect_des:
  assumes "\<Lambda> > 0"
  shows "const_intersect_design {0..<(length \<B>s)} (dual_blocks \<V> \<B>s) \<Lambda>"
proof -
  have "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x \<ge> \<Lambda>)" using const_index_lt_rep by simp
  then have "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)" using assms
    by (metis gr_zeroI le_zero_eq)
  then interpret pd: proper_design "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)"
    using dual_is_proper_design by (simp)
  show ?thesis proof (unfold_locales)
    fix b1 b2
    assume b1in: "b1 \<in># dual_blocks \<V> \<B>s"
    assume b2in:  "b2 \<in># remove1_mset b1 (dual_blocks \<V> \<B>s)"
    obtain j1 where b1eq: "b1 = \<B>s* ! j1" and j1lt: "j1 < length \<B>s*" using b1in
      by (metis dual_blocks_ordered_eq in_set_conv_nth set_mset_mset)
    obtain j2 where b2eq: "b2 = \<B>s* ! j2" and j2lt: "j2 < length \<B>s*" and "j1 \<noteq> j2"
      using b2in index_remove1_mset_ne
      by (metis (mono_tags) b1eq dual_blocks_ordered_eq j1lt nth_mem set_mset_mset)
    then show "b1 |\<inter>| b2 = \<Lambda>"
      using dual_blocks_const_intersect b1eq b2eq j1lt j2lt by simp
  qed
qed

lemma dual_is_simp_const_inter_des:
  assumes "\<Lambda> > 0"
  assumes "\<And> bl. bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "simple_const_intersect_design {0..<(length \<B>s)} (dual_blocks \<V> \<B>s) \<Lambda>"
proof -
  interpret d: const_intersect_design "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)"  "\<Lambda>"
    using assms dual_is_const_intersect_des by simp
  \<comment> \<open> Show that m < block size for all blocks \<close>
  have "\<And> x. x \<in> \<V> \<Longrightarrow> \<Lambda> < \<B> rep x" using assms incomplete_index_strict_lt_rep
    by blast
  then have "\<And> bl. bl \<in># (dual_blocks \<V> \<B>s) \<Longrightarrow> \<Lambda> < card bl"
    by (metis dual_blocks_size_is_rep_obtain)
  then interpret s: simple_design "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)"
    using d.simple_const_inter_block_size by simp
  show ?thesis by (unfold_locales)
qed
end

context ordered_const_intersect_design
begin

lemma dual_is_balanced:
  assumes "ps \<subseteq> {0..<length \<B>s}"
  assumes "card ps = 2"
  shows "(dual_blocks \<V> \<B>s) index ps = \<m>"
proof -
  obtain i1 i2 where psin: "ps = {i1, i2}" and neq: "i1 \<noteq> i2" using assms
    by (meson card_2_iff)
  then have lt: "i1 < \<b>" using assms
    by (metis atLeastLessThan_iff blocks_list_length insert_subset)
  have lt2: "i2 < \<b>" using assms psin
    by (metis atLeastLessThan_iff blocks_list_length insert_subset)
  then have inter: "(dual_blocks \<V> \<B>s) index ps = (\<B>s ! i1) |\<inter>| (\<B>s ! i2)" using dual_blocks_points_index_inter neq lt
    using dual_blocks_ordered_eq psin by presburger
  have inb1: "(\<B>s ! i1) \<in># \<B>"
    using lt by auto
  have inb2: "(\<B>s ! i2) \<in># (\<B> - {#(\<B>s ! i1)#})" using lt2 neq blocks_index_ne_belong
    by (metis blocks_list_length lt)
  thus ?thesis using const_intersect inb1 inb2 inter by blast
qed

lemma dual_is_pbd:
  assumes "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x > 0)"
  assumes "\<b> \<ge> 2"
  shows "pairwise_balance {0..<(length \<B>s)} (dual_blocks \<V> \<B>s) \<m>"
proof -
  interpret pd: proper_design "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)"
    using dual_is_proper_design
    by (simp add: assms)
  show ?thesis proof (unfold_locales)
    show "(1 ::nat) \<le> 2" by simp
    then show "2 \<le> dual_sys.\<v>" using  assms(2)
      by fastforce
    show "\<And>ps. ps \<subseteq> {0..<length \<B>s} \<Longrightarrow> card ps = 2 \<Longrightarrow> dual_blocks \<V> \<B>s index ps = \<m>"
      using dual_is_balanced by simp
  qed
qed

end

context ordered_sym_bibd
begin

lemma dual_is_balanced:
  assumes "ps \<subseteq> {0..<length \<B>s}"
  assumes "card ps = 2"
  shows "(dual_blocks \<V> \<B>s) index ps = \<Lambda>"
proof -
  obtain i1 i2 where psin: "ps = {i1, i2}" and neq: "i1 \<noteq> i2"
    using assms by (meson card_2_iff)
  then have lt: "i1 < \<b>" using assms
    by (metis atLeastLessThan_iff blocks_list_length insert_subset)
  have lt2: "i2 < \<b>" using assms psin
    by (metis atLeastLessThan_iff blocks_list_length insert_subset)
  then have inter: "(dual_blocks \<V> \<B>s) index ps = (\<B>s ! i1) |\<inter>| (\<B>s ! i2)"
    using dual_blocks_points_index_inter neq lt dual_blocks_ordered_eq psin by presburger
  have inb1: "(\<B>s ! i1) \<in># \<B>"
    using lt by auto
  have inb2: "(\<B>s ! i2) \<in># (\<B> - {#(\<B>s ! i1)#})" using lt2 neq blocks_index_simp_unique
    by (metis blocks_list_length in_remove1_mset_neq lt valid_blocks_index)
  thus ?thesis using sym_block_intersections_index inb1 inter by blast
qed

lemma dual_bibd: "bibd {0..<(length \<B>s)} (dual_blocks \<V> \<B>s) \<r> \<Lambda>"
proof -
  interpret block: block_design "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)" \<r>
    using dual_is_block_design by simp
  show ?thesis proof (unfold_locales)
    show "\<r> < dual_sys.\<v>"
      using dual_blocks_v incomplete symmetric_condition_1 symmetric_condition_2 by presburger
    show "(1 ::nat) \<le> 2" by simp
    have "\<v> \<ge> 2"
      by (simp add: t_lt_order)
    then have "\<b> \<ge> 2" using local.symmetric by auto
    then show "2 \<le> dual_sys.\<v>" by simp
    show "\<And>ps. ps \<subseteq> {0..<length \<B>s} \<Longrightarrow> card ps = 2 \<Longrightarrow> dual_blocks \<V> \<B>s index ps = \<Lambda>"
      using dual_is_balanced by simp
    show "2 \<le> \<r>" using r_ge_two by blast
  qed
qed

text \<open>The dual of a BIBD must by symmetric \<close>

lemma dual_bibd_symmetric: "symmetric_bibd {0..<(length \<B>s)} (dual_blocks \<V> \<B>s) \<r> \<Lambda>"
proof -
  interpret bibd: bibd "{0..<(length \<B>s)}" "(dual_blocks \<V> \<B>s)" \<r> \<Lambda>
    using dual_bibd by simp
  show ?thesis using dual_blocks_b local.symmetric by (unfold_locales) (simp)
qed

end

subsection \<open>Generalise Dual Concept \<close>
text \<open>The above formalisation relies on one translation of a dual design. However, any design
with an ordering of points and blocks such that the matrix is the transpose of the original is
a dual. The definition below encapsulates this concept. Additionally, we prove an isomorphism
exists between the generated dual from @{term "dual_blocks"} and any design satisfying the is dual
definition\<close>

context ordered_incidence_system
begin

definition is_dual:: "'b list \<Rightarrow> 'b set list \<Rightarrow> bool" where
"is_dual Vs' Bs' \<equiv> ordered_incidence_system Vs' Bs' \<and> (inc_mat_of Vs' Bs' = N\<^sup>T)"

lemma is_dualI:
  assumes "ordered_incidence_system Vs' Bs'"
  assumes "(inc_mat_of Vs' Bs' = N\<^sup>T)"
  shows "is_dual Vs' Bs'"
  by (auto simp add: is_dual_def assms)

lemma is_dualD1:
  assumes "is_dual Vs' Bs'"
  shows  "(inc_mat_of Vs' Bs' = N\<^sup>T)"
  using is_dual_def assms
  by auto

lemma is_dualD2:
  assumes "is_dual Vs' Bs'"
  shows  "ordered_incidence_system Vs' Bs'"
  using is_dual_def assms
  by auto

lemma generated_is_dual: "is_dual [0..<(length \<B>s)] \<B>s*"
proof -
  interpret osys: ordered_incidence_system "[0..<(length \<B>s)]" "\<B>s*" using dual_is_ordered_inc_sys by simp
  show ?thesis using is_dual_def
    by (simp add: is_dual_def dual_incidence_mat_eq_trans osys.ordered_incidence_system_axioms)
qed

lemma is_dual_isomorphism_generated:
  assumes "is_dual Vs' Bs'"
  shows "\<exists> \<pi>. incidence_system_isomorphism (set Vs') (mset Bs') ({0..<(length \<B>s)}) (dual_blocks \<V> \<B>s) \<pi>"
proof -
  interpret os2: ordered_incidence_system "([0..<(length \<B>s)])" "(\<B>s*)"
    by (simp add: dual_is_ordered_inc_sys)
  interpret os1: ordered_incidence_system Vs' Bs' using assms
    by (simp add: is_dualD2)
  interpret tos: two_ordered_sys Vs' Bs' "([0..<(length \<B>s)])" "(\<B>s*)"
     using assms  ordered_incidence_system_axioms two_ordered_sys.intro
     by (simp add: is_dualD2 two_ordered_sys.intro dual_is_ordered_inc_sys)
  have os2V: "os2.\<V> = {0..<(length \<B>s)}"
    by auto
  have os2B: "os2.\<B> = dual_blocks \<V> \<B>s"
    by (simp add: dual_blocks_ordered_eq)
  have "os1.N = inc_mat_of Vs' Bs'" by simp
  then have "os2.N = os1.N"
    using assms is_dualD1 dual_incidence_mat_eq_trans by fastforce
  thus ?thesis using tos.equal_inc_mat_isomorphism_ex os2V os2B by auto
qed

interpretation ordered_dual_sys: ordered_incidence_system "[0..<length \<B>s]" "\<B>s*"
  using dual_is_ordered_inc_sys by simp

text \<open>Original system is dual of the dual \<close>
lemma is_dual_rev: "ordered_dual_sys.is_dual \<V>s \<B>s"
  by (simp add: dual_incidence_mat_eq_trans_rev ordered_dual_sys.is_dualI ordered_incidence_system_axioms)

end

end


theory Quasi_Order
imports Main
begin

locale quasi_order =
fixes qle :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 60)
assumes qle_refl[iff]: "x \<preceq> x"
and qle_trans: "x \<preceq> y \<Longrightarrow> y \<preceq> z \<Longrightarrow> x \<preceq> z"
begin

definition in_qle :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "\<in>\<^sub>\<preceq>" 60) where
 "x \<in>\<^sub>\<preceq> M \<equiv> \<exists>y \<in> M. x \<preceq> y"

definition subseteq_qle :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<subseteq>\<^sub>\<preceq>" 60) where
 "M \<subseteq>\<^sub>\<preceq> N \<equiv> \<forall>x \<in> M. x \<in>\<^sub>\<preceq> N"

definition seteq_qle :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "=\<^sub>\<preceq>" 60) where
 "M =\<^sub>\<preceq> N  \<equiv>  M \<subseteq>\<^sub>\<preceq> N \<and> N \<subseteq>\<^sub>\<preceq> M"

lemmas "defs" = in_qle_def subseteq_qle_def seteq_qle_def

lemma subseteq_qle_refl[simp]: "M \<subseteq>\<^sub>\<preceq> M"
by(auto simp add: subseteq_qle_def in_qle_def)

lemma subseteq_qle_trans: "A \<subseteq>\<^sub>\<preceq> B \<Longrightarrow> B \<subseteq>\<^sub>\<preceq> C \<Longrightarrow> A \<subseteq>\<^sub>\<preceq> C"
by (simp add: subseteq_qle_def in_qle_def) (metis qle_trans)

lemma empty_subseteq_qle[simp]: "{} \<subseteq>\<^sub>\<preceq> A"
by (simp add: subseteq_qle_def)

lemma subseteq_qleI2: "(\<And>x. x \<in> M \<Longrightarrow> \<exists>y \<in> N. x \<preceq> y) \<Longrightarrow> M \<subseteq>\<^sub>\<preceq> N"
by (auto simp add: subseteq_qle_def in_qle_def)

lemma subseteq_qleD2: "M \<subseteq>\<^sub>\<preceq> N \<Longrightarrow> x \<in> M \<Longrightarrow> \<exists>y \<in> N. x \<preceq> y"
by (auto simp add: subseteq_qle_def in_qle_def)

lemma seteq_qle_refl[iff]: "A =\<^sub>\<preceq> A"
by (simp add: seteq_qle_def)

lemma seteq_qle_trans: "A =\<^sub>\<preceq> B \<Longrightarrow> B =\<^sub>\<preceq> C \<Longrightarrow> A =\<^sub>\<preceq> C"
by (simp add: seteq_qle_def) (metis subseteq_qle_trans)

end

end


(*
  File:    Pochhammer_Polynomials.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Falling factorial as a polynomial\<close>
theory Pochhammer_Polynomials
imports
  Complex_Main
  "HOL-Library.Stirling"
  "HOL-Computational_Algebra.Polynomial"
begin

definition pochhammer_poly :: "nat \<Rightarrow> 'a :: {comm_semiring_1} poly" where
  "pochhammer_poly n = Poly [of_nat (stirling n k). k \<leftarrow> [0..<Suc n]]"

lemma pochhammer_poly_code [code abstract]:
  "coeffs (pochhammer_poly n) = map of_nat (stirling_row n)"
  by (simp add: pochhammer_poly_def stirling_row_def Let_def)

lemma coeff_pochhammer_poly: "coeff (pochhammer_poly n) k = of_nat (stirling n k)"
  by (simp add: pochhammer_poly_def nth_default_def del: upt_Suc)

lemma degree_pochhammer_poly [simp]: "degree (pochhammer_poly n) = n"
  by (simp add: degree_eq_length_coeffs pochhammer_poly_def)

lemma pochhammer_poly_0 [simp]: "pochhammer_poly 0 = 1"
  by (simp add: pochhammer_poly_def)

lemma pochhammer_poly_Suc: "pochhammer_poly (Suc n) = [:of_nat n,1:] * pochhammer_poly n"
  by (cases "n = 0") (simp_all add: poly_eq_iff coeff_pochhammer_poly coeff_pCons split: nat.split)

lemma pochhammer_poly_altdef: "pochhammer_poly n = (\<Prod>i<n. [:of_nat i,1:])"
  by (induction n) (simp_all add: pochhammer_poly_Suc)

lemma eval_pochhammer_poly: "poly (pochhammer_poly n) k = pochhammer k n"
  by (cases n) (auto simp add: pochhammer_poly_altdef poly_prod add_ac lessThan_Suc_atMost
                               pochhammer_Suc_prod atLeast0AtMost)

lemma pochhammer_poly_Suc':
    "pochhammer_poly (Suc n) = pCons 0 (pcompose (pochhammer_poly n) [:1,1:])"
  by (simp add: pochhammer_poly_altdef prod.lessThan_Suc_shift pcompose_prod pcompose_pCons add_ac del: prod.lessThan_Suc)

end


section \<open>ListUtilities\<close>

text \<open>
  \file{ListUtilities} defines a (proper) prefix relation for lists, and proves some
  additional lemmata, mostly about lists.
\<close>

theory ListUtilities
imports Main
begin

subsection \<open>List Prefixes\<close>

inductive prefixList ::
  "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "prefixList [] (x # xs)"
| "prefixList xa xb \<Longrightarrow> prefixList (x # xa) (x # xb)"

lemma PrefixListHasTail:
fixes
  l1 :: "'a list" and
  l2 :: "'a list"
assumes
  "prefixList l1 l2"
shows
  "\<exists> l . l2 = l1 @ l \<and> l \<noteq> []"
using assms by (induct rule: prefixList.induct, auto)

lemma PrefixListMonotonicity:
fixes
  l1 :: "'a list" and
  l2 :: "'a list"
assumes
  "prefixList l1 l2"
shows
  "length l1 < length l2"
using assms by (induct rule: prefixList.induct, auto)

lemma TailIsPrefixList :
fixes
  l1 :: "'a list" and
  tail :: "'a list"
assumes "tail \<noteq> []"
shows "prefixList l1 (l1 @ tail)"
using assms
proof (induct l1, auto)
  have "\<exists> x xs . tail = x # xs"
    using assms by (metis neq_Nil_conv)
  thus "prefixList [] tail"
    using assms  by (metis prefixList.intros(1))
next
  fix a l1
  assume "prefixList l1 (l1 @ tail)"
  thus "prefixList (a # l1) (a # l1 @ tail)"
    by (metis prefixList.intros(2))
qed

lemma PrefixListTransitive:
fixes
  l1 :: "'a list" and
  l2 :: "'a list" and
  l3 :: "'a list"
assumes
  "prefixList l1 l2"
  "prefixList l2 l3"
shows
  "prefixList l1 l3"
using assms
proof -
  from assms(1) have "\<exists> l12 . l2 = l1 @ l12 \<and> l12 \<noteq> []"
    using PrefixListHasTail by auto
  then obtain l12 where Extend1: "l2 = l1 @ l12 \<and> l12 \<noteq> []" by blast
  from assms(2) have Extend2: "\<exists> l23 . l3 = l2 @ l23 \<and> l23 \<noteq> []"
    using PrefixListHasTail by auto
  then obtain l23 where Extend2: "l3 = l2 @ l23 \<and> l23 \<noteq> []" by blast
  have "l3 = l1 @ (l12 @ l23) \<and> (l12 @ l23) \<noteq> []"
    using Extend1 Extend2 by simp
  hence "\<exists> l . l3 = l1 @ l \<and> l \<noteq> []" by blast
  thus "prefixList l1 l3" using TailIsPrefixList by auto
qed

subsection \<open>Lemmas for lists and nat predicates\<close>

lemma NatPredicateTippingPoint:
fixes
  n2 Pr
assumes
  Min:     "0 < n2" and
  Pr0:     "Pr 0" and
  NotPrN2: "\<not>Pr n2"
shows
  "\<exists>n<n2. Pr n \<and> \<not>Pr (Suc n)"
proof (rule classical, simp)
  assume Asm: "\<forall>n. Pr n \<longrightarrow> n < n2 \<longrightarrow> Pr (Suc n)"
  have "\<And>n. n < n2 \<Longrightarrow> Pr n"
  proof-
    fix n
    show "n < n2 \<Longrightarrow> Pr n"
    by (induct n, auto simp add: Pr0 Asm)
  qed
  hence False
    using Asm[rule_format, of "n2 - 1"] Min NotPrN2 by auto
  thus ?thesis by auto
qed

lemma MinPredicate:
fixes
  P::"nat \<Rightarrow> bool"
assumes
  "\<exists> n . P n"
shows
  "(\<exists> n0 . (P n0) \<and> (\<forall> n' . (P n') \<longrightarrow> (n' \<ge> n0)))"
using assms
by (metis LeastI2_wellorder Suc_n_not_le_n)

text \<open>
  The lemma \isb{MinPredicate2} describes one case of \isb{MinPredicate}
  where the aforementioned smallest element is zero.
\<close>

lemma MinPredicate2:
fixes
  P::"nat \<Rightarrow> bool"
assumes
 "\<exists> n . P n"
shows
  "\<exists> n0 . (P n0) \<and> (n0 = 0 \<or> \<not> P (n0 - 1))"
using assms MinPredicate
by (metis add_diff_cancel_right' diff_is_0_eq diff_mult_distrib mult_eq_if)

text \<open>
  \isb{PredicatePairFunction} allows to obtain functions mapping two arguments
  to pairs from 4-ary predicates which are left-total on their first
  two arguments.
\<close>

lemma PredicatePairFunction:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
shows
  "\<exists>f . \<forall>x1 x2 . \<exists>y1 y2 .
    (f x1 x2) = (y1, y2)
    \<and> (P x1 x2 (fst (f x1 x2)) (snd (f x1 x2)))"
proof -
  define P' where "P' x y = P (fst x) (snd x) (fst y) (snd y)" for x y
  hence "\<forall>x. \<exists>y. P' x  y" using A1 by auto
  hence "\<exists>f. \<forall>x. P' x (f x)" by metis
  then obtain f where "\<forall>x. P' x (f x)" by blast
  moreover define f' where "f' x1 x2 = f (x1, x2)" for x1 x2
  ultimately have "\<forall>x. P' x (f' (fst x) (snd x))" by auto
  hence "\<exists>f'. \<forall>x. P' x (f' (fst x) (snd x))" by blast
  thus ?thesis using P'_def by auto
qed

lemma PredicatePairFunctions2:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
obtains f1 f2  where
  "\<forall>x1 x2 . \<exists>y1 y2 .
    (f1 x1 x2) = y1 \<and> (f2 x1 x2) = y2
    \<and> (P x1 x2 (f1 x1 x2) (f2 x1 x2))"
proof (cases thesis, auto)
  assume ass: "\<And>f1 f2. \<forall>x1 x2. P x1 x2 (f1 x1 x2) (f2 x1 x2) \<Longrightarrow> False"
  obtain f where F: "\<forall>x1 x2. \<exists>y1 y2. f x1 x2 = (y1, y2) \<and> P x1 x2 (fst (f x1 x2)) (snd (f x1 x2))"
    using PredicatePairFunction[OF A1] by blast
  define f1 where "f1 x1 x2 = fst (f x1 x2)" for x1 x2
  define f2 where "f2 x1 x2 = snd (f x1 x2)" for x1 x2
  show False
    using ass[of f1 f2] F unfolding f1_def f2_def by auto
qed

lemma PredicatePairFunctions2Inv:
fixes
  P::"'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool"
assumes
  A1: "\<forall>x1 x2 . \<exists>y1 y2 . (P x1 x2 y1 y2)"
obtains f1 f2  where
  "\<forall>x1 x2 . (P x1 x2 (f1 x1 x2) (f2 x1 x2))"
using PredicatePairFunctions2[OF A1] by auto

lemma SmallerMultipleStepsWithLimit:
fixes
  k A limit
assumes
  "\<forall> n \<ge> limit . (A (Suc n)) < (A n)"
shows
  "\<forall> n \<ge> limit . (A (n + k)) \<le> (A n) - k"
proof(induct k,auto)
  fix n k
  assume IH: "\<forall>n\<ge>limit. A (n + k) \<le> A n - k" "limit \<le> n"
  hence "A (Suc (n + k)) < A (n + k)" using assms by simp
  hence "A (Suc (n + k)) < A n - k" using IH by auto
  thus "A (Suc (n + k)) \<le> A n - Suc k"
    by (metis Suc_lessI add_Suc_right add_diff_cancel_left'
       less_diff_conv less_or_eq_imp_le add.commute)
qed

lemma PrefixSameOnLow:
fixes
  l1 l2
assumes
  "prefixList l1 l2"
shows
  "\<forall> index < length l1 . l1 ! index = l2 ! index"
using assms
proof(induct rule: prefixList.induct, auto)
  fix xa xb ::"'a list" and x index
  assume AssumpProof: "prefixList xa xb"
        "\<forall>index < length xa. xa ! index = xb ! index"
        "prefixList l1 l2" "index < Suc (length xa)"
  show "(x # xa) ! index = (x # xb) ! index" using AssumpProof
  proof(cases "index = 0", auto)
  qed
qed

lemma KeepProperty:
fixes
  P Q low
assumes
  "\<forall> i \<ge> low . P i \<longrightarrow> (P (Suc i) \<and> Q i)" "P low"
shows
  "\<forall> i \<ge> low . Q i"
using assms
proof(clarify)
  fix i
  assume Assump:
    "\<forall>i\<ge>low. P i \<longrightarrow> P (Suc i) \<and> Q i"
    "P low"
    "low \<le> i"
  hence "\<forall>i\<ge>low. P i \<longrightarrow> P (Suc i)" by blast
  hence "\<forall> i \<ge> low . P i" using Assump(2) by (metis dec_induct)
  hence "P i" using Assump(3) by blast
  thus "Q i" using Assump by blast
qed

lemma ListLenDrop:
fixes
  i la lb
assumes
  "i < length lb"
  "i \<ge> la"
shows
  "lb ! i \<in> set (drop la lb)"
using assms
by (metis Cons_nth_drop_Suc in_set_member member_rec(1)
       set_drop_subset_set_drop rev_subsetD)

lemma DropToShift:
fixes
  l i list
assumes
  "l + i < length list"
shows
  "(drop l list) ! i = list ! (l + i)"
using assms
by (induct l, auto)

lemma SetToIndex:
fixes
  a and liste::"'a list"
assumes
  AssumpSetToIndex: "a \<in> set liste"
shows
  "\<exists> index < length liste . a = liste ! index"
proof -
  have LenInduct:
    "\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> a \<in> set ys
          \<longrightarrow> (\<exists>index<length ys. a = ys ! index)
          \<Longrightarrow> a \<in> set xs \<longrightarrow> (\<exists>index<length xs. a = xs ! index)"
  proof(auto)
    fix xs
    assume AssumpLengthInduction:
      "\<forall>ys. length ys < length xs \<longrightarrow> a \<in> set ys
      \<longrightarrow> (\<exists>index<length ys. a = ys ! index)" "a \<in> set xs"
    have "\<exists> x xs' . xs = x#xs'" using AssumpLengthInduction(2)
      by (metis ListMem.cases ListMem_iff)
    then obtain x xs' where XSSplit: "xs = x#xs'" by blast
    hence "a \<in> insert x (set xs')" using set_simps AssumpLengthInduction
      by simp
    hence "a = x \<or> a \<in> set xs'" by simp
    thus "\<exists>index<length xs. a = xs ! index"
    proof(cases "a = x",auto)
      show "\<exists>index<length xs. x = xs ! index" using XSSplit by auto
    next
      assume AssumpCases: "a \<in> set xs'" "a \<noteq> x"
      have "length xs' < length xs" using XSSplit by simp
      hence "\<exists>index<length xs'. a = xs' ! index"
        using AssumpLengthInduction(1) AssumpCases(1) by simp
      thus "\<exists>index<length xs. a = xs ! index" using XSSplit by auto
    qed
  qed
  thus "\<exists> index < length liste . a = liste ! index"
    using length_induct[of
      "\<lambda>l. a \<in> set l \<longrightarrow> (\<exists> index < length l . a = l ! index)" "liste"]
    AssumpSetToIndex by blast
qed

lemma DropToIndex:
fixes
  a::"'a" and l liste
assumes
  AssumpDropToIndex: "a \<in> set (drop l liste)"
shows
  "\<exists> i \<ge> l . i < length liste \<and> a = liste ! i"
proof-
  have "\<exists> index < length (drop l liste) . a = (drop l liste) ! index"
    using AssumpDropToIndex SetToIndex[of "a" "drop l liste"] by blast
  then obtain index where Index: "index < length (drop l liste)"
    "a = (drop l liste) ! index" by blast
  have "l + index < length liste" using Index(1)
    by (metis length_drop less_diff_conv add.commute)
  hence "a = liste ! (l + index)"
    using DropToShift[of "l" "index"] Index(2) by blast
  thus "\<exists>i\<ge>l. i < length liste \<and> a = liste ! i"
    by (metis \<open>l + index < length liste\<close> le_add1)
qed

end


theory ex_sort
  imports Main
begin

value "[1::nat, 3,2]"

(*
fun my_sort::"nat list \<Rightarrow> nat list" where
  "my_sort [] = []"|
  "my_sort [x] = [x]"|
  "my_sort [x1,x2] = (if (x1 < x2) then ([x1,x2]) else ([x2,x1]))"|
  "my_sort (x1#x2#xs) = (if (x1 < x2) then (x1#(my_sort (x2#xs))) else (my_sort (x2#x1#xs)))"
*)

fun myInsert::"nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "myInsert x [] = [x]"|
  "myInsert x (y#ys) = (if (x\<le>y) then (x#y#ys) else (y#(myInsert x ys)))"

fun mySort::"nat list \<Rightarrow> nat list" where
  "mySort [] = []"|
  "mySort (x#xs) = myInsert x (mySort xs)"

value "mySort [3,2,1]"

lemma ms: "\<forall>i j. i<j \<longrightarrow> j<length xs \<longrightarrow> \<not>(mySort xs) ! 1 > (mySort xs) ! 1"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by blast
qed

lemma subls: "Suc (length xs) = length (myInsert a xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by simp
qed

lemma ls: "length xs = length (mySort xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (simp add:subls)
qed

(*export_code mySort in OCaml*)

end


(*  Title:      HOL/Computational_Algebra/Normalized_Fraction.thy
    Author:     Manuel Eberl
*)

theory Normalized_Fraction
imports
  Main
  Euclidean_Algorithm
  Fraction_Field
begin

definition quot_to_fract :: "'a :: {idom} \<times> 'a \<Rightarrow> 'a fract" where
  "quot_to_fract = (\<lambda>(a,b). Fraction_Field.Fract a b)"

definition normalize_quot :: "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "normalize_quot =
     (\<lambda>(a,b). if b = 0 then (0,1) else let d = gcd a b * unit_factor b in (a div d, b div d))"

lemma normalize_quot_zero [simp]:
  "normalize_quot (a, 0) = (0, 1)"
  by (simp add: normalize_quot_def)

lemma normalize_quot_proj:
  "fst (normalize_quot (a, b)) = a div (gcd a b * unit_factor b)"
  "snd (normalize_quot (a, b)) = normalize b div gcd a b" if "b \<noteq> 0"
  using that by (simp_all add: normalize_quot_def Let_def mult.commute [of _ "unit_factor b"] dvd_div_mult2_eq mult_unit_dvd_iff')

definition normalized_fracts :: "('a :: {ring_gcd,idom_divide} \<times> 'a) set" where
  "normalized_fracts = {(a,b). coprime a b \<and> unit_factor b = 1}"

lemma not_normalized_fracts_0_denom [simp]: "(a, 0) \<notin> normalized_fracts"
  by (auto simp: normalized_fracts_def)

lemma unit_factor_snd_normalize_quot [simp]:
  "unit_factor (snd (normalize_quot x)) = 1"
  by (simp add: normalize_quot_def case_prod_unfold Let_def dvd_unit_factor_div
                mult_unit_dvd_iff unit_factor_mult unit_factor_gcd)

lemma snd_normalize_quot_nonzero [simp]: "snd (normalize_quot x) \<noteq> 0"
  using unit_factor_snd_normalize_quot[of x]
  by (auto simp del: unit_factor_snd_normalize_quot)

lemma normalize_quot_aux:
  fixes a b
  assumes "b \<noteq> 0"
  defines "d \<equiv> gcd a b * unit_factor b"
  shows   "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
          "d dvd a" "d dvd b" "d \<noteq> 0"
proof -
  from assms show "d dvd a" "d dvd b"
    by (simp_all add: d_def mult_unit_dvd_iff)
  thus "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d" "d \<noteq> 0"
    by (auto simp: normalize_quot_def Let_def d_def \<open>b \<noteq> 0\<close>)
qed

lemma normalize_quotE:
  assumes "b \<noteq> 0"
  obtains d where "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
                  "d dvd a" "d dvd b" "d \<noteq> 0"
  using that[OF normalize_quot_aux[OF assms]] .

lemma normalize_quotE':
  assumes "snd x \<noteq> 0"
  obtains d where "fst x = fst (normalize_quot x) * d" "snd x = snd (normalize_quot x) * d"
                  "d dvd fst x" "d dvd snd x" "d \<noteq> 0"
proof -
  from normalize_quotE[OF assms, of "fst x"] guess d .
  from this show ?thesis unfolding prod.collapse by (intro that[of d])
qed

lemma coprime_normalize_quot:
  "coprime (fst (normalize_quot x)) (snd (normalize_quot x))"
  by (simp add: normalize_quot_def case_prod_unfold div_mult_unit2)
    (metis coprime_mult_self_right_iff div_gcd_coprime unit_div_mult_self unit_factor_is_unit)

lemma normalize_quot_in_normalized_fracts [simp]: "normalize_quot x \<in> normalized_fracts"
  by (simp add: normalized_fracts_def coprime_normalize_quot case_prod_unfold)

lemma normalize_quot_eq_iff:
  assumes "b \<noteq> 0" "d \<noteq> 0"
  shows   "normalize_quot (a,b) = normalize_quot (c,d) \<longleftrightarrow> a * d = b * c"
proof -
  define x y where "x = normalize_quot (a,b)" and "y = normalize_quot (c,d)"
  from normalize_quotE[OF assms(1), of a] normalize_quotE[OF assms(2), of c]
    obtain d1 d2
      where "a = fst x * d1" "b = snd x * d1" "c = fst y * d2" "d = snd y * d2" "d1 \<noteq> 0" "d2 \<noteq> 0"
    unfolding x_def y_def by metis
  hence "a * d = b * c \<longleftrightarrow> fst x * snd y = snd x * fst y" by simp
  also have "\<dots> \<longleftrightarrow> fst x = fst y \<and> snd x = snd y"
    by (intro coprime_crossproduct') (simp_all add: x_def y_def coprime_normalize_quot)
  also have "\<dots> \<longleftrightarrow> x = y" using prod_eqI by blast
  finally show "x = y \<longleftrightarrow> a * d = b * c" ..
qed

lemma normalize_quot_eq_iff':
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot x = normalize_quot y \<longleftrightarrow> fst x * snd y = snd x * fst y"
  using assms by (cases x, cases y, hypsubst) (subst normalize_quot_eq_iff, simp_all)

lemma normalize_quot_id: "x \<in> normalized_fracts \<Longrightarrow> normalize_quot x = x"
  by (auto simp: normalized_fracts_def normalize_quot_def case_prod_unfold)

lemma normalize_quot_idem [simp]: "normalize_quot (normalize_quot x) = normalize_quot x"
  by (rule normalize_quot_id) simp_all

lemma fractrel_iff_normalize_quot_eq:
  "fractrel x y \<longleftrightarrow> normalize_quot x = normalize_quot y \<and> snd x \<noteq> 0 \<and> snd y \<noteq> 0"
  by (cases x, cases y) (auto simp: fractrel_def normalize_quot_eq_iff)

lemma fractrel_normalize_quot_left:
  assumes "snd x \<noteq> 0"
  shows   "fractrel (normalize_quot x) y \<longleftrightarrow> fractrel x y"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lemma fractrel_normalize_quot_right:
  assumes "snd x \<noteq> 0"
  shows   "fractrel y (normalize_quot x) \<longleftrightarrow> fractrel y x"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lift_definition quot_of_fract ::
  "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract \<Rightarrow> 'a \<times> 'a"
    is normalize_quot
  by (subst (asm) fractrel_iff_normalize_quot_eq) simp_all

lemma quot_to_fract_quot_of_fract [simp]: "quot_to_fract (quot_of_fract x) = x"
  unfolding quot_to_fract_def
proof transfer
  fix x :: "'a \<times> 'a" assume rel: "fractrel x x"
  define x' where "x' = normalize_quot x"
  obtain a b where [simp]: "x = (a, b)" by (cases x)
  from rel have "b \<noteq> 0" by simp
  from normalize_quotE[OF this, of a] guess d .
  hence "a = fst x' * d" "b = snd x' * d" "d \<noteq> 0" "snd x' \<noteq> 0" by (simp_all add: x'_def)
  thus "fractrel (case x' of (a, b) \<Rightarrow> if b = 0 then (0, 1) else (a, b)) x"
    by (auto simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract: "quot_of_fract (quot_to_fract x) = normalize_quot x"
proof (cases "snd x = 0")
  case True
  thus ?thesis unfolding quot_to_fract_def
    by transfer (simp add: case_prod_unfold normalize_quot_def)
next
  case False
  thus ?thesis unfolding quot_to_fract_def by transfer (simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract':
  "x \<in> normalized_fracts \<Longrightarrow> quot_of_fract (quot_to_fract x) = x"
  unfolding quot_to_fract_def by transfer (auto simp: normalize_quot_id)

lemma quot_of_fract_in_normalized_fracts [simp]: "quot_of_fract x \<in> normalized_fracts"
  by transfer simp

lemma normalize_quotI:
  assumes "a * d = b * c" "b \<noteq> 0" "(c, d) \<in> normalized_fracts"
  shows   "normalize_quot (a, b) = (c, d)"
proof -
  from assms have "normalize_quot (a, b) = normalize_quot (c, d)"
    by (subst normalize_quot_eq_iff) auto
  also have "\<dots> = (c, d)" by (intro normalize_quot_id) fact
  finally show ?thesis .
qed

lemma td_normalized_fract:
  "type_definition quot_of_fract quot_to_fract normalized_fracts"
  by standard (simp_all add: quot_of_fract_quot_to_fract')

lemma quot_of_fract_add_aux:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "(fst x * snd y + fst y * snd x) * (snd (normalize_quot x) * snd (normalize_quot y)) =
             snd x * snd y * (fst (normalize_quot x) * snd (normalize_quot y) +
             snd (normalize_quot x) * fst (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] guess d . note d = this
  from normalize_quotE'[OF assms(2)] guess e . note e = this
  show ?thesis by (simp_all add: d e algebra_simps)
qed

locale fract_as_normalized_quot
begin
setup_lifting td_normalized_fract
end

lemma quot_of_fract_add:
  "quot_of_fract (x + y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d + b * c, b * d))"
  by transfer (insert quot_of_fract_add_aux,
               simp_all add: Let_def case_prod_unfold normalize_quot_eq_iff)

lemma quot_of_fract_uminus:
  "quot_of_fract (-x) = (let (a,b) = quot_of_fract x in (-a, b))"
  by transfer (auto simp: case_prod_unfold Let_def normalize_quot_def dvd_neg_div mult_unit_dvd_iff)

lemma quot_of_fract_diff:
  "quot_of_fract (x - y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d - b * c, b * d))" (is "_ = ?rhs")
proof -
  have "x - y = x + -y" by simp
  also have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_add quot_of_fract_uminus Let_def case_prod_unfold) simp_all
  finally show ?thesis .
qed

lemma normalize_quot_mult_coprime:
  assumes "coprime a b" "coprime c d" "unit_factor b = 1" "unit_factor d = 1"
  defines "e \<equiv> fst (normalize_quot (a, d))" and "f \<equiv> snd (normalize_quot (a, d))"
     and  "g \<equiv> fst (normalize_quot (c, b))" and "h \<equiv> snd (normalize_quot (c, b))"
  shows   "normalize_quot (a * c, b * d) = (e * g, f * h)"
proof (rule normalize_quotI)
  from assms have "gcd a b = 1" "gcd c d = 1"
    by simp_all
  from assms have "b \<noteq> 0" "d \<noteq> 0" by auto
  with assms have "normalize b = b" "normalize d = d"
    by (auto intro: normalize_unit_factor_eqI)
  from normalize_quotE [OF \<open>b \<noteq> 0\<close>, of c] guess k .
  note k = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from normalize_quotE [OF \<open>d \<noteq> 0\<close>, of a] guess l .
  note l = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from k l show "a * c * (f * h) = b * d * (e * g)"
    by (metis e_def f_def g_def h_def mult.commute mult.left_commute)
  from assms have [simp]: "unit_factor f = 1" "unit_factor h = 1"
    by simp_all
  from assms have "coprime e f" "coprime g h" by (simp_all add: coprime_normalize_quot)
  with k l assms(1,2) \<open>b \<noteq> 0\<close> \<open>d \<noteq> 0\<close> \<open>unit_factor b = 1\<close> \<open>unit_factor d = 1\<close>
    \<open>normalize b = b\<close> \<open>normalize d = d\<close>
  show "(e * g, f * h) \<in> normalized_fracts"
    by (simp add: normalized_fracts_def unit_factor_mult e_def f_def g_def h_def
      coprime_normalize_quot dvd_unit_factor_div unit_factor_gcd)
      (metis coprime_mult_left_iff coprime_mult_right_iff)
qed (insert assms(3,4), auto)

lemma normalize_quot_mult:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot (fst x * fst y, snd x * snd y) = normalize_quot
             (fst (normalize_quot x) * fst (normalize_quot y),
              snd (normalize_quot x) * snd (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] guess d . note d = this
  from normalize_quotE'[OF assms(2)] guess e . note e = this
  show ?thesis by (simp_all add: d e algebra_simps normalize_quot_eq_iff)
qed

lemma quot_of_fract_mult:
  "quot_of_fract (x * y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
      in  (e*g, f*h))"
  by transfer
     (simp add: split_def Let_def coprime_normalize_quot normalize_quot_mult normalize_quot_mult_coprime)

lemma normalize_quot_0 [simp]:
    "normalize_quot (0, x) = (0, 1)" "normalize_quot (x, 0) = (0, 1)"
  by (simp_all add: normalize_quot_def)

lemma normalize_quot_eq_0_iff [simp]: "fst (normalize_quot x) = 0 \<longleftrightarrow> fst x = 0 \<or> snd x = 0"
  by (auto simp: normalize_quot_def case_prod_unfold Let_def div_mult_unit2 dvd_div_eq_0_iff)

lemma fst_quot_of_fract_0_imp: "fst (quot_of_fract x) = 0 \<Longrightarrow> snd (quot_of_fract x) = 1"
  by transfer auto

lemma normalize_quot_swap:
  assumes "a \<noteq> 0" "b \<noteq> 0"
  defines "a' \<equiv> fst (normalize_quot (a, b))" and "b' \<equiv> snd (normalize_quot (a, b))"
  shows   "normalize_quot (b, a) = (b' div unit_factor a', a' div unit_factor a')"
proof (rule normalize_quotI)
  from normalize_quotE[OF assms(2), of a] guess d . note d = this [folded assms(3,4)]
  show "b * (a' div unit_factor a') = a * (b' div unit_factor a')"
    using assms(1,2) d
    by (simp add: div_unit_factor [symmetric] unit_div_mult_swap mult_ac del: div_unit_factor)
  have "coprime a' b'" by (simp add: a'_def b'_def coprime_normalize_quot)
  thus "(b' div unit_factor a', a' div unit_factor a') \<in> normalized_fracts"
    using assms(1,2) d
    by (auto simp add: normalized_fracts_def ac_simps dvd_div_unit_iff elim: coprime_imp_coprime)
qed fact+

lemma quot_of_fract_inverse:
  "quot_of_fract (inverse x) =
     (let (a,b) = quot_of_fract x; d = unit_factor a
      in  if d = 0 then (0, 1) else (b div d, a div d))"
proof (transfer, goal_cases)
  case (1 x)
  from normalize_quot_swap[of "fst x" "snd x"] show ?case
    by (auto simp: Let_def case_prod_unfold)
qed

lemma normalize_quot_div_unit_left:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x div u, y) = (x' div u, y')"
proof (cases "y = 0")
  case False
  define v where "v = 1 div u"
  with \<open>is_unit u\<close> have "is_unit v" and u: "\<And>a. a div u = a * v"
    by simp_all
  from \<open>is_unit v\<close> have "coprime v = top"
    by (simp add: fun_eq_iff is_unit_left_imp_coprime)
  from normalize_quotE[OF False, of x] guess d .
  note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1"
    by (simp_all add: coprime_normalize_quot)
  with d \<open>coprime v = top\<close> have "normalize_quot (x * v, y) = (x' * v, y')"
    by (auto simp: normalized_fracts_def intro: normalize_quotI)
  then show ?thesis
    by (simp add: u)
qed (simp_all add: assms)

lemma normalize_quot_div_unit_right:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, y div u) = (x' * u, y')"
proof (cases "y = 0")
  case False
  from normalize_quotE[OF this, of x] guess d . note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1" by (simp_all add: coprime_normalize_quot)
  with d \<open>is_unit u\<close> show ?thesis
    by (auto simp add: normalized_fracts_def is_unit_left_imp_coprime unit_div_eq_0_iff intro: normalize_quotI)
qed (simp_all add: assms)

lemma normalize_quot_normalize_left:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (normalize x, y) = (x' div unit_factor x, y')"
  using normalize_quot_div_unit_left[of "unit_factor x" x y]
  by (cases "x = 0") (simp_all add: assms)

lemma normalize_quot_normalize_right:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, normalize y) = (x' * unit_factor y, y')"
  using normalize_quot_div_unit_right[of "unit_factor y" x y]
  by (cases "y = 0") (simp_all add: assms)

lemma quot_of_fract_0 [simp]: "quot_of_fract 0 = (0, 1)"
  by transfer auto

lemma quot_of_fract_1 [simp]: "quot_of_fract 1 = (1, 1)"
  by transfer (rule normalize_quotI, simp_all add: normalized_fracts_def)

lemma quot_of_fract_divide:
  "quot_of_fract (x / y) = (if y = 0 then (0, 1) else
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,c); (g,h) = normalize_quot (d,b)
      in  (e * g, f * h)))" (is "_ = ?rhs")
proof (cases "y = 0")
  case False
  hence A: "fst (quot_of_fract y) \<noteq> 0" by transfer auto
  have "x / y = x * inverse y" by (simp add: divide_inverse)
  also from False A have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_mult quot_of_fract_inverse)
       (simp_all add: Let_def case_prod_unfold fst_quot_of_fract_0_imp
          normalize_quot_div_unit_left normalize_quot_div_unit_right
          normalize_quot_normalize_right normalize_quot_normalize_left)
  finally show ?thesis .
qed simp_all

end


(*  Author:     Amine Chaieb
    Author:     Florian Haftmann
    Author:     Lukas Bulwahn
    Author:     Manuel Eberl
*)

section \<open>Stirling numbers of first and second kind\<close>

theory Stirling
imports MainRLT
begin

subsection \<open>Stirling numbers of the second kind\<close>

fun Stirling :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "Stirling 0 0 = 1"
  | "Stirling 0 (Suc k) = 0"
  | "Stirling (Suc n) 0 = 0"
  | "Stirling (Suc n) (Suc k) = Suc k * Stirling n (Suc k) + Stirling n k"

lemma Stirling_1 [simp]: "Stirling (Suc n) (Suc 0) = 1"
  by (induct n) simp_all

lemma Stirling_less [simp]: "n < k \<Longrightarrow> Stirling n k = 0"
  by (induct n k rule: Stirling.induct) simp_all

lemma Stirling_same [simp]: "Stirling n n = 1"
  by (induct n) simp_all

lemma Stirling_2_2: "Stirling (Suc (Suc n)) (Suc (Suc 0)) = 2 ^ Suc n - 1"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "Stirling (Suc (Suc (Suc n))) (Suc (Suc 0)) =
      2 * Stirling (Suc (Suc n)) (Suc (Suc 0)) + Stirling (Suc (Suc n)) (Suc 0)"
    by simp
  also have "\<dots> = 2 * (2 ^ Suc n - 1) + 1"
    by (simp only: Suc Stirling_1)
  also have "\<dots> = 2 ^ Suc (Suc n) - 1"
  proof -
    have "(2::nat) ^ Suc n - 1 > 0"
      by (induct n) simp_all
    then have "2 * ((2::nat) ^ Suc n - 1) > 0"
      by simp
    then have "2 \<le> 2 * ((2::nat) ^ Suc n)"
      by simp
    with add_diff_assoc2 [of 2 "2 * 2 ^ Suc n" 1]
    have "2 * 2 ^ Suc n - 2 + (1::nat) = 2 * 2 ^ Suc n + 1 - 2" .
    then show ?thesis
      by (simp add: nat_distrib)
  qed
  finally show ?case by simp
qed

lemma Stirling_2: "Stirling (Suc n) (Suc (Suc 0)) = 2 ^ n - 1"
  using Stirling_2_2 by (cases n) simp_all

subsection \<open>Stirling numbers of the first kind\<close>

fun stirling :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "stirling 0 0 = 1"
  | "stirling 0 (Suc k) = 0"
  | "stirling (Suc n) 0 = 0"
  | "stirling (Suc n) (Suc k) = n * stirling n (Suc k) + stirling n k"

lemma stirling_0 [simp]: "n > 0 \<Longrightarrow> stirling n 0 = 0"
  by (cases n) simp_all

lemma stirling_less [simp]: "n < k \<Longrightarrow> stirling n k = 0"
  by (induct n k rule: stirling.induct) simp_all

lemma stirling_same [simp]: "stirling n n = 1"
  by (induct n) simp_all

lemma stirling_Suc_n_1: "stirling (Suc n) (Suc 0) = fact n"
  by (induct n) auto

lemma stirling_Suc_n_n: "stirling (Suc n) n = Suc n choose 2"
  by (induct n) (auto simp add: numerals(2))

lemma stirling_Suc_n_2:
  assumes "n \<ge> Suc 0"
  shows "stirling (Suc n) 2 = (\<Sum>k=1..n. fact n div k)"
  using assms
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by (simp add: numerals(2))
  next
    case Suc
    then have geq1: "Suc 0 \<le> n"
      by simp
    have "stirling (Suc (Suc n)) 2 = Suc n * stirling (Suc n) 2 + stirling (Suc n) (Suc 0)"
      by (simp only: stirling.simps(4)[of "Suc n"] numerals(2))
    also have "\<dots> = Suc n * (\<Sum>k=1..n. fact n div k) + fact n"
      using Suc.hyps[OF geq1]
      by (simp only: stirling_Suc_n_1 of_nat_fact of_nat_add of_nat_mult)
    also have "\<dots> = Suc n * (\<Sum>k=1..n. fact n div k) + Suc n * fact n div Suc n"
      by (metis nat.distinct(1) nonzero_mult_div_cancel_left)
    also have "\<dots> = (\<Sum>k=1..n. fact (Suc n) div k) + fact (Suc n) div Suc n"
      by (simp add: sum_distrib_left div_mult_swap dvd_fact)
    also have "\<dots> = (\<Sum>k=1..Suc n. fact (Suc n) div k)"
      by simp
    finally show ?thesis .
  qed
qed

lemma of_nat_stirling_Suc_n_2:
  assumes "n \<ge> Suc 0"
  shows "(of_nat (stirling (Suc n) 2)::'a::field_char_0) = fact n * (\<Sum>k=1..n. (1 / of_nat k))"
  using assms
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by (auto simp add: numerals(2))
  next
    case Suc
    then have geq1: "Suc 0 \<le> n"
      by simp
    have "(of_nat (stirling (Suc (Suc n)) 2)::'a) =
        of_nat (Suc n * stirling (Suc n) 2 + stirling (Suc n) (Suc 0))"
      by (simp only: stirling.simps(4)[of "Suc n"] numerals(2))
    also have "\<dots> = of_nat (Suc n) * (fact n * (\<Sum>k = 1..n. 1 / of_nat k)) + fact n"
      using Suc.hyps[OF geq1]
      by (simp only: stirling_Suc_n_1 of_nat_fact of_nat_add of_nat_mult)
    also have "\<dots> = fact (Suc n) * (\<Sum>k = 1..n. 1 / of_nat k) + fact (Suc n) * (1 / of_nat (Suc n))"
      using of_nat_neq_0 by auto
    also have "\<dots> = fact (Suc n) * (\<Sum>k = 1..Suc n. 1 / of_nat k)"
      by (simp add: distrib_left)
    finally show ?thesis .
  qed
qed

lemma sum_stirling: "(\<Sum>k\<le>n. stirling n k) = fact n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "(\<Sum>k\<le>Suc n. stirling (Suc n) k) = stirling (Suc n) 0 + (\<Sum>k\<le>n. stirling (Suc n) (Suc k))"
    by (simp only: sum.atMost_Suc_shift)
  also have "\<dots> = (\<Sum>k\<le>n. stirling (Suc n) (Suc k))"
    by simp
  also have "\<dots> = (\<Sum>k\<le>n. n * stirling n (Suc k) + stirling n k)"
    by simp
  also have "\<dots> = n * (\<Sum>k\<le>n. stirling n (Suc k)) + (\<Sum>k\<le>n. stirling n k)"
    by (simp add: sum.distrib sum_distrib_left)
  also have "\<dots> = n * fact n + fact n"
  proof -
    have "n * (\<Sum>k\<le>n. stirling n (Suc k)) = n * ((\<Sum>k\<le>Suc n. stirling n k) - stirling n 0)"
      by (metis add_diff_cancel_left' sum.atMost_Suc_shift)
    also have "\<dots> = n * (\<Sum>k\<le>n. stirling n k)"
      by (cases n) simp_all
    also have "\<dots> = n * fact n"
      using Suc.hyps by simp
    finally have "n * (\<Sum>k\<le>n. stirling n (Suc k)) = n * fact n" .
    moreover have "(\<Sum>k\<le>n. stirling n k) = fact n"
      using Suc.hyps .
    ultimately show ?thesis by simp
  qed
  also have "\<dots> = fact (Suc n)" by simp
  finally show ?case .
qed

lemma stirling_pochhammer:
  "(\<Sum>k\<le>n. of_nat (stirling n k) * x ^ k) = (pochhammer x n :: 'a::comm_semiring_1)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "of_nat (n * stirling n 0) = (0 :: 'a)" by (cases n) simp_all
  then have "(\<Sum>k\<le>Suc n. of_nat (stirling (Suc n) k) * x ^ k) =
      (of_nat (n * stirling n 0) * x ^ 0 +
      (\<Sum>i\<le>n. of_nat (n * stirling n (Suc i)) * (x ^ Suc i))) +
      (\<Sum>i\<le>n. of_nat (stirling n i) * (x ^ Suc i))"
    by (subst sum.atMost_Suc_shift) (simp add: sum.distrib ring_distribs)
  also have "\<dots> = pochhammer x (Suc n)"
    by (subst sum.atMost_Suc_shift [symmetric])
      (simp add: algebra_simps sum.distrib sum_distrib_left pochhammer_Suc flip: Suc)
  finally show ?case .
qed

text \<open>A row of the Stirling number triangle\<close>

definition stirling_row :: "nat \<Rightarrow> nat list"
  where "stirling_row n = [stirling n k. k \<leftarrow> [0..<Suc n]]"

lemma nth_stirling_row: "k \<le> n \<Longrightarrow> stirling_row n ! k = stirling n k"
  by (simp add: stirling_row_def del: upt_Suc)

lemma length_stirling_row [simp]: "length (stirling_row n) = Suc n"
  by (simp add: stirling_row_def)

lemma stirling_row_nonempty [simp]: "stirling_row n \<noteq> []"
  using length_stirling_row[of n] by (auto simp del: length_stirling_row)

subsubsection \<open>Efficient code\<close>

text \<open>
  Naively using the defining equations of the Stirling numbers of the first
  kind to compute them leads to exponential run time due to repeated
  computations. We can use memoisation to compute them row by row without
  repeating computations, at the cost of computing a few unneeded values.

  As a bonus, this is very efficient for applications where an entire row of
  Stirling numbers is needed.
\<close>

definition zip_with_prev :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'b list"
  where "zip_with_prev f x xs = map2 f (x # xs) xs"

lemma zip_with_prev_altdef:
  "zip_with_prev f x xs =
    (if xs = [] then [] else f x (hd xs) # [f (xs!i) (xs!(i+1)). i \<leftarrow> [0..<length xs - 1]])"
proof (cases xs)
  case Nil
  then show ?thesis
    by (simp add: zip_with_prev_def)
next
  case (Cons y ys)
  then have "zip_with_prev f x xs = f x (hd xs) # zip_with_prev f y ys"
    by (simp add: zip_with_prev_def)
  also have "zip_with_prev f y ys = map (\<lambda>i. f (xs ! i) (xs ! (i + 1))) [0..<length xs - 1]"
    unfolding Cons
    by (induct ys arbitrary: y)
      (simp_all add: zip_with_prev_def upt_conv_Cons flip: map_Suc_upt del: upt_Suc)
  finally show ?thesis
    using Cons by simp
qed

primrec stirling_row_aux
  where
    "stirling_row_aux n y [] = [1]"
  | "stirling_row_aux n y (x#xs) = (y + n * x) # stirling_row_aux n x xs"

lemma stirling_row_aux_correct:
  "stirling_row_aux n y xs = zip_with_prev (\<lambda>a b. a + n * b) y xs @ [1]"
  by (induct xs arbitrary: y) (simp_all add: zip_with_prev_def)

lemma stirling_row_code [code]:
  "stirling_row 0 = [1]"
  "stirling_row (Suc n) = stirling_row_aux n 0 (stirling_row n)"
proof goal_cases
  case 1
  show ?case by (simp add: stirling_row_def)
next
  case 2
  have "stirling_row (Suc n) =
    0 # [stirling_row n ! i + stirling_row n ! (i+1) * n. i \<leftarrow> [0..<n]] @ [1]"
  proof (rule nth_equalityI, goal_cases length nth)
    case (nth i)
    from nth have "i \<le> Suc n"
      by simp
    then consider "i = 0 \<or> i = Suc n" | "i > 0" "i \<le> n"
      by linarith
    then show ?case
    proof cases
      case 1
      then show ?thesis
        by (auto simp: nth_stirling_row nth_append)
    next
      case 2
      then show ?thesis
        by (cases i) (simp_all add: nth_append nth_stirling_row)
    qed
  next
    case length
    then show ?case by simp
  qed
  also have "0 # [stirling_row n ! i + stirling_row n ! (i+1) * n. i \<leftarrow> [0..<n]] @ [1] =
      zip_with_prev (\<lambda>a b. a + n * b) 0 (stirling_row n) @ [1]"
    by (cases n) (auto simp add: zip_with_prev_altdef stirling_row_def hd_map simp del: upt_Suc)
  also have "\<dots> = stirling_row_aux n 0 (stirling_row n)"
    by (simp add: stirling_row_aux_correct)
  finally show ?case .
qed

lemma stirling_code [code]:
  "stirling n k =
    (if k = 0 then (if n = 0 then 1 else 0)
     else if k > n then 0
     else if k = n then 1
     else stirling_row n ! k)"
  by (simp add: nth_stirling_row)

end