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

section \<open> Dual Systems \<close>
text \<open>The concept of a dual incidence system \cite{colbournHandbookCombinatorialDesigns2007}
 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{stinsonCombinatorialDesignsConstructions2004}\<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 Named
  imports "../00Utils/Variable" "../00Utils/Utils"
begin

datatype nexpr =
  NVar var
  | NConst nat
  | NLam var nexpr
  | NApp nexpr nexpr

primrec all_vars :: "nexpr \<Rightarrow> var set" where
  "all_vars (NVar x) = {x}"
| "all_vars (NConst k) = {}"
| "all_vars (NLam x e) = insert x (all_vars e)"
| "all_vars (NApp e\<^sub>1 e\<^sub>2) = all_vars e\<^sub>1 \<union> all_vars e\<^sub>2"

primrec valn :: "nexpr \<Rightarrow> bool" where
  "valn (NVar x) = False"
| "valn (NConst k) = True"
| "valn (NLam x e) = True"
| "valn (NApp e\<^sub>1 e\<^sub>2) = False"

primrec subst_var :: "var \<Rightarrow> var \<Rightarrow> nexpr \<Rightarrow> nexpr" where
  "subst_var x x' (NVar y) = NVar (if x = y then x' else y)"
| "subst_var x x' (NConst k) = NConst k"
| "subst_var x x' (NLam y e) = NLam y (if x = y then e else subst_var x x' e)"
| "subst_var x x' (NApp e\<^sub>1 e\<^sub>2) = NApp (subst_var x x' e\<^sub>1) (subst_var x x' e\<^sub>2)"

fun substn :: "var \<Rightarrow> nexpr \<Rightarrow> nexpr \<Rightarrow> nexpr" where
  "substn x e' (NVar y) = (if x = y then e' else NVar y)"
| "substn x e' (NConst k) = NConst k"
| "substn x e' (NLam y e) = (
    let z = fresh (all_vars e' \<union> all_vars e \<union> {x, y})
    in NLam z (substn x e' (subst_var y z e)))"
| "substn x e' (NApp e\<^sub>1 e\<^sub>2) = NApp (substn x e' e\<^sub>1) (substn x e' e\<^sub>2)"

inductive evaln :: "nexpr \<Rightarrow> nexpr \<Rightarrow> bool" (infix "\<Down>" 50) where
  evn_const [simp]: "NConst k \<Down> NConst k"
| evn_lam [simp]: "NLam x e \<Down> NLam x e"
| evn_app [simp]: "e\<^sub>1 \<Down> NLam x e\<^sub>1' \<Longrightarrow> e\<^sub>2 \<Down> v\<^sub>2 \<Longrightarrow> substn x v\<^sub>2 e\<^sub>1' \<Down> v \<Longrightarrow> NApp e\<^sub>1 e\<^sub>2 \<Down> v"

lemma [simp]: "finite (all_vars e)"
  by (induction e) simp_all

(* We, obviously, do not have safety here yet. The relevant proofs are in 03Debruijn/NameRemoval. *)

lemma [simp]: "e \<Down> v \<Longrightarrow> valn v"
  by (induction e v rule: evaln.induct) simp_all

lemma val_no_evaln: "e \<Down> v \<Longrightarrow> valn e \<Longrightarrow> v = e"
  by (induction e v rule: evaln.induct) simp_all

theorem determinismn: "e \<Down> v \<Longrightarrow> e \<Down> v' \<Longrightarrow> v = v'"
proof (induction e v arbitrary: v' rule: evaln.induct)
  case (evn_const k)
  thus ?case by (induction "NConst k" v' rule: evaln.induct) simp_all
next
  case (evn_lam x e)
  thus ?case by (induction "NLam x e" v' rule: evaln.induct) simp_all
next
  case (evn_app e\<^sub>1 x e\<^sub>1' e\<^sub>2 v\<^sub>2 v)
  from evn_app(7, 1, 2, 3, 4, 5, 6) show ?case
    by (induction "NApp e\<^sub>1 e\<^sub>2" v' rule: evaln.induct) blast+
qed

end


section \<open>Predicate Transformers Semantics of Invariant Diagrams\<close>

theory Diagram
imports Hoare
begin

text \<open>
This theory introduces the concept of a transition diagram and proves
a number of Hoare total corectness rules for these diagrams. As before
the diagrams are introduced using their predicate transformer semantics.

A transition diagram $D$ is a function from pairs of indexes to predicate
transformers: $D:I\times I \to (\mathit{State}\ \mathit{set}\to \mathit{State}\ \mathit{set})$, or more
general $D:I\times I \to \mathit{Ptran}$, where $\mathit{Ptran}$ is a complete lattice. The elements
of $I$ are called situations and intuitively a diagram is executed starting
in a situation $i\in I$ by choosing a transition $D (i,j)$ which is enabled
and continuing similarly from $j$ if there are enabled trasitions. The
execution of a diagram stops when there are no more transitions enabled or
when it fails.

The semantics of a transition diagram is an indexed predicate transformer
($I\to \mathit{State}\ \mathit{set}$).
If $Q:I\to \mathit{State}\ \mathit{set}$ is an indexed predicate, then $p = \mathit{pt}\ D\ Q\ i$ is a
weakest predicate such that if the executution of $D$ starts in a state
$s\in p$ from situation $i$, then it terminates, and if it terminates
in situation $j$ and state $s'$, then $s'\in Q \  j$.

We introduce first the indexed predicate transformer $\mathit{step}\ D$ of executing
one step of diagram $D$. The predicate $step\ D\ Q\ i$ is true for those
states $s$ from which the execution of one step of $D$ starting in situation
$i$ ends in one of the situations $j$ such that $Q \, j$ is true.

\<close>

definition
  "step D Q i = (INF j . D (i, j) (Q j) :: _ :: complete_lattice)"

definition
  "dmono D = (\<forall> ij . mono (D ij))"

lemma dmono_mono [simp]: "dmono D \<Longrightarrow> mono (D ij)"
  by (simp add: dmono_def)

theorem mono_step [simp]:
  "dmono D \<Longrightarrow> mono (step D)"
  apply (simp add: dmono_def mono_def le_fun_def step_def Inf_fun_def)
  apply auto
  apply (rule INF_greatest)
  apply auto
  apply (rule_tac y = "D(xa, j) (x j)" in order_trans)
  apply auto
  apply (rule INF_lower)
  by auto

text \<open>
The indexed predicate transformer of a transition diagram is defined as the least
fixpoint of the unfolding of the execution of the diagram. The indexed predicate
transformer $dgr\ D\ U$ is the choice between executing one step of $D$ follwed by
$U$ ($(\mathit{step}\ D)\circ U$) or skip if no transion of $D$ is enabled
($\mathit{assume}\ \neg \mathit{grd} (\mathit{step}\ D)$).
\<close>

definition
  "dgr D U = ((step D) o U) \<sqinter> [.-(grd (step D)).]"

theorem mono_mono_dgr [simp]: "dmono D \<Longrightarrow> mono_mono (dgr D)"
  apply (simp add: mono_mono_def mono_def)
  apply safe
  apply (simp_all add: dgr_def)
  apply (simp_all add: le_fun_def inf_fun_def)
  apply safe
  apply (rule_tac y = "(step D (x xa) xb)" in order_trans)
  apply simp_all
  apply (case_tac "mono (step D)")
  apply (simp add: mono_def)
  apply (simp add: le_fun_def)
  apply simp
  apply (rule_tac y = "(step D (f x) xa)" in order_trans)
  apply simp_all
  apply (case_tac "mono (step D)")
  apply (simp add: mono_def)
  apply (simp_all add: le_fun_def)
  apply (rule_tac y = "(assume (- grd (step D)) x xa)" in order_trans)
  apply simp_all
  apply (case_tac "mono (assume (- grd (step D)))")
  apply (simp add: mono_def le_fun_def)
  by simp

definition
  "pt D = lfp (dgr D)"

text \<open>
If $U$ is an indexed predicate transformer and if $P, Q:I\to \mathit{State} \ \mathit{set}$
are indexed predicates, then the meaning of the Hoare triple defined earlier,
$\models P \{ | U | \} Q$, is that if
we start $U$ in a state $s$ from a situation $i$ such that $s\in P\, i$,
then U terminates, and if it terminates in $s'$ and situation $j$, then
$s'\in Q\ j$ is true.

Next theorem shows that in a diagram all transitions are correct
if and only if $\mathit{step}\ D$ is correct.
\<close>

theorem hoare_step:
  "(\<forall> i j . \<Turnstile> (P i) {| D(i,j) |} (Q j) ) = (\<Turnstile> P {| step D |} Q)"
  apply safe
  apply (simp add: le_fun_def Hoare_def step_def)
  apply safe
  apply (rule INF_greatest)
  apply auto
  apply (simp add: le_fun_def Hoare_def step_def)
  apply (erule_tac x = i in allE)
  apply (rule_tac y = "INF j. D(i, j) (Q j)" in order_trans)
  apply auto
  apply (rule INF_lower)
  by auto

text \<open>
Next theorem provides the first proof rule for total correctnes of transition
diagrams. If all transitions are correct and if a global variant decreases
on every transition then the diagram is correct and it terminates. The variant
must decrease according to a well founded and transitive relation.
\<close>

theorem hoare_diagram:
  "dmono D \<Longrightarrow> (\<forall> w i j . \<Turnstile> X w i  {| D(i,j) |} Sup_less X w j) \<Longrightarrow>
    \<Turnstile> (Sup (range X)) {| pt D |} (Sup(range X) \<sqinter> -(grd (step D)))"
  apply (simp add: hoare_step pt_def)
  apply (rule hoare_fixpoint)
  apply auto
  apply (simp add: dgr_def)
  apply (simp add: hoare_choice)
  apply safe
  apply (simp add: hoare_sequential)
  apply auto
  apply (simp add: hoare_assume)
  apply (rule le_infI1)
  by (rule SUP_upper, auto)

text\<open>
This theorem is a more general form of the more familiar form with a variant $t$
which must decrease. If we take $X\ w\ i = (Y \ i \land t\ i = w)$, then the
second hypothesis of the theorem above becomes
$\models Y \ i \land t\ i = w \{| D(i,j) |\} Y \ i \land t \ i < w$. However,
the more general form of the theorem is needed, because
in data refinements, the form $Y\ i \land t\ i = w$ cannot be preserved.
\<close>

text \<open>
The drawback of this theorem is that the variant must be decreased on every
transitions which may be too cumbersome for practical applications. A similar
situation occur when introducing proof rules for mutually recursive procedures.
There the straightforward generalization of the proof rule of a recursive procedure
to mutually recursive procedures suffers of a similar problem. We would need
to prove that the variant decreases before every recursive call. Nipkow
\cite{nipkow:2002} has introduced a rule for mutually recursive procedures
in which the variant is required to decrease only in a sequence of recursive
calls before calling again a procedure in this sequence. We introduce a
similar proof rule in which the variant depends also on the situation
indexes.
\<close>

locale DiagramTermination =
  fixes pair:: "'a \<Rightarrow> 'b \<Rightarrow> ('c::well_founded_transitive)"
begin

definition
  "SUP_L_P X u i = (SUP v\<in>{v. pair v i < u}. X v i :: _ :: complete_lattice)"

definition
  "SUP_LE_P X u i = (SUP v\<in>{v. pair v i \<le> u}. X v i :: _ :: complete_lattice)"

lemma SUP_L_P_upper:
  "pair v i < u \<Longrightarrow> P v i \<le> SUP_L_P P u i"
  by (auto simp add: SUP_L_P_def intro: SUP_upper)

lemma SUP_L_P_least:
  "(!! v . pair v i < u \<Longrightarrow> P v i \<le> Q) \<Longrightarrow> SUP_L_P P u i \<le> Q"
  by (simp add: SUP_L_P_def, rule SUP_least, auto)

lemma SUP_LE_P_upper:
  "pair v i \<le> u \<Longrightarrow> P v i \<le> SUP_LE_P P u i"
  by (auto simp add: SUP_LE_P_def intro: SUP_upper)

lemma SUP_LE_P_least:
  "(!! v . pair v i \<le> u \<Longrightarrow> P v i \<le> Q) \<Longrightarrow> SUP_LE_P P u i \<le> Q"
  by (simp add: SUP_LE_P_def, rule SUP_least, auto)

lemma SUP_SUP_L [simp]: "Sup (range (SUP_LE_P X)) = Sup (range X)"
  apply (simp add: fun_eq_iff Sup_fun_def image_comp, clarify)
  apply (rule antisym)
  apply (rule SUP_least)
  apply (rule SUP_LE_P_least)
  apply (rule SUP_upper, simp)
  apply (rule SUP_least)
  apply (rule_tac y = "SUP_LE_P X (pair xa x) x" in order_trans)
  apply (rule SUP_LE_P_upper, simp)
  by (rule SUP_upper, simp)

lemma SUP_L_SUP_LE_P [simp]: "Sup_less (SUP_LE_P X) = SUP_L_P X"
  apply (rule antisym)
  apply (subst le_fun_def, safe)
  apply (rule Sup_less_least)
  apply (subst le_fun_def, safe)
  apply (rule SUP_LE_P_least)
  apply (rule SUP_L_P_upper, simp)
  apply (simp add: le_fun_def, safe)
  apply (rule SUP_L_P_least)
  apply (rule_tac y = "SUP_LE_P X (pair v xa) xa" in order_trans)
  apply (rule SUP_LE_P_upper, simp)
  apply (cut_tac P = "SUP_LE_P X" in Sup_less_upper)
  by (simp, simp add: le_fun_def)

end

theorem (in DiagramTermination) hoare_diagram2:
  "dmono D \<Longrightarrow> (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<Longrightarrow>
    \<Turnstile> (Sup (range X)) {| pt D |} ((Sup (range  X)) \<sqinter> (-(grd (step D))))"
  apply (frule_tac X = "SUP_LE_P X" in hoare_diagram)
  apply auto
  apply (simp add: SUP_LE_P_def)
  apply (unfold hoare_Sup [THEN sym])
  apply auto
  apply (rule_tac Q = "SUP_L_P X (pair p i) j" in hoare_mono)
  apply auto
  apply (rule SUP_L_P_least)
  apply (rule SUP_L_P_upper)
  apply (rule order_trans3)
  by auto

lemma mono_pt [simp]: "dmono D \<Longrightarrow> mono (pt D)"
  apply (drule mono_mono_dgr)
  by (simp add: pt_def)

theorem (in DiagramTermination) hoare_diagram3:
  "dmono D \<Longrightarrow>
     (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<Longrightarrow>
      P \<le> Sup (range X) \<Longrightarrow>  ((Sup (range X)) \<sqinter> (-(grd (step D)))) \<le> Q \<Longrightarrow>
      \<Turnstile> P {| pt D |} Q"
  apply (rule hoare_mono)
  apply auto
  apply (rule hoare_pre)
  apply auto
  apply (rule hoare_diagram2)
  by auto

text\<open>
The following definition introduces the concept of correct Hoare triples for diagrams.
\<close>

definition (in DiagramTermination)
  Hoare_dgr :: "('b \<Rightarrow> ('u::{complete_distrib_lattice, boolean_algebra})) \<Rightarrow> ('b \<times> 'b \<Rightarrow> 'u \<Rightarrow> 'u) \<Rightarrow> ('b \<Rightarrow> 'u) \<Rightarrow> bool" ("\<turnstile> (_){| _ |}(_) "
  [0,0,900] 900) where
  "\<turnstile> P {| D |} Q \<equiv> (\<exists> X . (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<and>
       P = Sup (range X) \<and> Q = ((Sup (range  X)) \<sqinter> (-(grd (step D)))))"

definition (in DiagramTermination)
  Hoare_dgr1 :: "('b \<Rightarrow> ('u::{complete_distrib_lattice, boolean_algebra})) \<Rightarrow> ('b \<times> 'b \<Rightarrow> 'u \<Rightarrow> 'u) \<Rightarrow> ('b \<Rightarrow> 'u) \<Rightarrow> bool" ("\<turnstile>1 (_){| _ |}(_) "
  [0,0,900] 900) where
  "\<turnstile>1 P {| D |} Q \<equiv> (\<exists> X . (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<and>
      P \<le> Sup (range X) \<and> ((Sup (range X)) \<sqinter> (-(grd (step D)))) \<le> Q)"

theorem (in DiagramTermination) hoare_dgr_correctness:
  "dmono D \<Longrightarrow> (\<turnstile> P {| D |} Q) \<Longrightarrow> (\<Turnstile> P {| pt D |} Q)"
  apply (simp add: Hoare_dgr_def)
  apply safe
  apply (rule hoare_diagram3)
  by auto

theorem  (in DiagramTermination) hoare_dgr_correctness1:
  "dmono D \<Longrightarrow> (\<turnstile>1 P {| D |} Q) \<Longrightarrow> (\<Turnstile> P {| pt D |} Q)"
  apply (simp add: Hoare_dgr1_def)
  apply safe
  apply (rule hoare_diagram3)
  by auto

definition
  "dgr_demonic Q ij = [:Q ij:]"

theorem dgr_demonic_mono[simp]:
  "dmono (dgr_demonic Q)"
  by (simp add: dmono_def dgr_demonic_def)

definition
  "dangelic R Q i = angelic (R i) (Q i)"

lemma  grd_dgr:
  "((grd (step D) i)::('a::complete_boolean_algebra)) = \<Squnion> {P . \<exists> j . P = grd (D(i,j))}"
  apply (simp add: grd_def step_def)
  apply (unfold step_def uminus_Inf)
  apply (case_tac "(uminus ` range (\<lambda>j::'b. D (i, j) \<bottom>)) = {P::'a. \<exists>j::'b. P = - D (i, j) \<bottom>}")
  apply (auto cong del: SUP_cong_simp)
  done

lemma  grd_dgr_set:
  "((grd (step D) i)::('a set)) = Union {P . \<exists> j . P = grd (D(i,j))}"
  by (simp add: grd_dgr)

lemma not_grd_dgr [simp]: "(a \<in> (- grd (step D) i)) = (\<forall> j . a \<notin> grd (D(i,j)))"
 apply (simp add: grd_dgr)
  by auto

lemma not_grd_dgr2 [simp]: "a \<notin> (grd (step D) i) = (\<forall> j . a \<notin> grd (D(i,j)))"
  apply (subst not_grd_dgr [THEN sym])
  by simp
end


(*<*)
theory TortoiseHare
imports
  Basis
begin

(*>*)
section\<open> The Tortoise and the Hare \label{sec:th} \<close>

text (in properties) \<open>

The key to the Tortoise and Hare algorithm is that any @{term "nu"}
such that @{term "seq (nu + nu) = seq nu"} must be divisible by @{term
"lambda"}. Intuitively the first @{term "nu"} steps get us into the
loop. If the second @{term "nu"} steps return us to the same value of
the sequence, then we must have gone around the loop one or more
times.

\<close>

lemma (in properties) lambda_dvd_nu:
  assumes "seq (i + i) = seq i"
  shows "lambda dvd i"
proof(cases "i = 0")
  case False
  with assms have "mu \<le> i" by (auto simp: properties_loops_ge_mu)
  with assms have "seq (i + i mod lambda) = seq i"
    using properties_loop[where i="i + i mod lambda" and j="i div lambda"] by simp
  from properties_distinct_contrapos[OF this] show ?thesis
    by simp (meson dvd_eq_mod_eq_0 mod_less_divisor not_less properties_lambda_gt_0)
qed simp

text (in properties) \<open>

The program is split into three loops; we find @{term "nu"}, @{term
"mu"} and @{term "lambda"} in that order.

\<close>

subsection\<open> Finding \<open>nu\<close> \<close>

text\<open>

The state space of the program tracks each of the variables we wish to
discover, and the current positions of the Tortoise and Hare.

\<close>

record 'a state =
  nu :: nat \<comment> \<open>\<open>\<nu>\<close>\<close>
  m :: nat  \<comment> \<open>\<open>\<mu>\<close>\<close>
  l :: nat  \<comment> \<open>\<open>\<lambda>\<close>\<close>
  hare :: "'a"
  tortoise :: "'a"

context properties
begin

text\<open>

The Hare proceeds at twice the speed of the Tortoise. The program
tracks how many steps the Tortoise has taken in @{term "nu"}.

\<close>

definition (in fx0) find_nu :: "'a state \<Rightarrow> 'a state" where
  "find_nu \<equiv>
    (\<lambda>s. s\<lparr> nu := 1, tortoise := f(x0), hare := f(f(x0)) \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> nu := nu s + 1, tortoise := f(tortoise s), hare := f(f(hare s)) \<rparr>)"

text\<open>

If this program terminates, we expect \<open>seq \<circ> (nu
\<^bold>+ nu) \<^bold>= seq \<circ> nu\<close> to hold in the final state.

The simplest approach to showing termination is to define a suitable
\<open>nu\<close> in terms of \<open>lambda\<close> and \<open>mu\<close>, which also
gives us an upper bound on the number of calls to \<open>f\<close>.

\<close>

definition nu_witness :: nat where
  "nu_witness \<equiv> mu + lambda - mu mod lambda"

text\<open>

This constant has the following useful properties:

\<close>

lemma nu_witness_properties:
  "mu < nu_witness"
  "nu_witness \<le> lambda + mu"
  "lambda dvd nu_witness"
  "mu = 0 \<Longrightarrow> nu_witness = lambda"
unfolding nu_witness_def
using properties_lambda_gt_0
apply (simp_all add: less_diff_conv divide_simps)
apply (metis minus_mod_eq_div_mult [symmetric] dvd_def mod_add_self2 mult.commute)
done

text\<open>

These demonstrate that @{term "nu_witness"} has the key property:

\<close>

lemma nu_witness:
  shows "seq (nu_witness + nu_witness) = seq nu_witness"
using nu_witness_properties properties_loop
by (clarsimp simp: dvd_def field_simps)

text\<open>

Termination amounts to showing that the Tortoise gets closer to @{term
"nu_witness"} on each iteration of the loop.

\<close>

definition find_nu_measure :: "(nat \<times> nat) set" where
  "find_nu_measure \<equiv> measure (\<lambda>\<nu>. nu_witness - \<nu>)"

lemma find_nu_measure_wellfounded:
  "wf find_nu_measure"
by (simp add: find_nu_measure_def)

lemma find_nu_measure_decreases:
  assumes "seq (\<nu> + \<nu>) \<noteq> seq \<nu>"
  assumes "\<nu> \<le> nu_witness"
  shows "(Suc \<nu>, \<nu>) \<in> find_nu_measure"
using nu_witness_properties nu_witness assms
by (auto simp: find_nu_measure_def le_eq_less_or_eq)

text\<open>

The remainder of the Hoare proof is straightforward.

\<close>

lemma find_nu:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> find_nu \<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> seq \<circ> (nu \<^bold>+ nu) \<^bold>= seq \<circ> nu \<^bold>\<and> hare \<^bold>= seq \<circ> nu\<rbrace>"
apply (simp add: find_nu_def)
apply (rule hoare_pre)
 apply (rule whileI[where I="nu \<^bold>\<in> \<langle>{0<..nu_witness}\<rangle> \<^bold>\<and> (\<^bold>\<forall>i. \<langle>0 < i\<rangle> \<^bold>\<and> \<langle>i\<rangle> \<^bold>< nu \<^bold>\<longrightarrow> \<langle>seq (i + i) \<noteq> seq i\<rangle>)
                            \<^bold>\<and> tortoise \<^bold>= seq \<circ> nu \<^bold>\<and> hare \<^bold>= seq \<circ> (nu \<^bold>+ nu)"
                       and r="inv_image find_nu_measure nu"]
             wp_intro)+
    using nu_witness_properties nu_witness
    apply (fastforce simp: le_eq_less_or_eq elim: less_SucE)
   apply (simp add: find_nu_measure_wellfounded)
  apply (simp add: find_nu_measure_decreases)
 apply (rule wp_intro)
using nu_witness_properties
apply auto
done

subsubsection\<open> Side observations \<close>

text\<open>

We can also show termination ala \citet{Filliatre:2007}.

\<close>

definition find_nu_measures :: "(nat \<times> nat) set" where
  "find_nu_measures \<equiv>
    measures [\<lambda>\<nu>. mu - \<nu>, \<lambda>\<nu>. LEAST i. seq (\<nu> + \<nu> + i) = seq \<nu>]"

lemma find_nu_measures_wellfounded:
  "wf find_nu_measures"
by (simp add: find_nu_measures_def)

lemma find_nu_measures_existence:
  assumes \<nu>: "mu \<le> \<nu>"
  shows "\<exists>i. seq (\<nu> + \<nu> + i) = seq \<nu>"
proof(cases "seq (\<nu> + \<nu>) = seq \<nu>")
 case False
 from properties_lambda_gt_0 obtain k where k: "\<nu> \<le> k * lambda"
   by (metis One_nat_def Suc_leI mult.right_neutral mult_le_mono order_refl)
 from \<nu> k have "seq (\<nu> + \<nu> + (k * lambda - \<nu>)) = seq (mu + (\<nu> - mu) + k * lambda)" by (simp add: field_simps)
 also from \<nu> properties_loop have "\<dots> = seq \<nu>" by simp
 finally show ?thesis by blast
qed (simp add: exI[where x=0])

lemma find_nu_measures_decreases:
  assumes \<nu>: "seq (\<nu> + \<nu>) \<noteq> seq \<nu>"
  shows "(Suc \<nu>, \<nu>) \<in> find_nu_measures"
proof(cases "mu \<le> \<nu>")
  case True
  then have "mu \<le> Suc \<nu>" by simp
  have "(LEAST i. seq (Suc \<nu> + Suc \<nu> + i) = seq (Suc \<nu>)) < (LEAST i. seq (\<nu> + \<nu> + i) = seq \<nu>)"
  proof(rule LeastI2_wellorder_ex[OF find_nu_measures_existence[OF \<open>mu \<le> Suc \<nu>\<close>]],
        rule LeastI2_wellorder_ex[OF find_nu_measures_existence[OF \<open>mu \<le> \<nu>\<close>]])
    fix x y
    assume x: "seq (Suc \<nu> + Suc \<nu> + x) = seq (Suc \<nu>)"
              "\<forall>z. seq (Suc \<nu> + Suc \<nu> + z) = seq (Suc \<nu>) \<longrightarrow> x \<le> z"
    assume y: "seq (\<nu> + \<nu> + y) = seq \<nu>"
    from \<nu> \<open>mu \<le> \<nu>\<close> y have "0 < y" by (cases y) simp_all
    with y have "seq (Suc \<nu> + Suc \<nu> + (y - 1)) = seq (Suc \<nu>)" by (auto elim: seq_inj)
    with \<open>0 < y\<close> spec[OF x(2), where x="y - 1"] y show "x < y" by simp
  qed
  with True \<nu> show ?thesis by (simp add: find_nu_measures_def)
qed (auto simp: find_nu_measures_def)

lemma "find_nu_Filliâtre":
  "\<lbrace>\<langle>True\<rangle>\<rbrace> find_nu \<lbrace>\<langle>0\<rangle> \<^bold>< nu \<^bold>\<and> seq \<circ> (nu \<^bold>+ nu) \<^bold>= seq \<circ> nu \<^bold>\<and> hare \<^bold>= seq \<circ> nu\<rbrace>"
apply (simp add: find_nu_def)
apply (rule hoare_pre)
 apply (rule whileI[where I="\<langle>0\<rangle> \<^bold>< nu \<^bold>\<and> tortoise \<^bold>= seq \<circ> nu \<^bold>\<and> hare \<^bold>= seq \<circ> (nu \<^bold>+ nu)"
                      and r="inv_image find_nu_measures nu"]
             wp_intro)+
    apply clarsimp
   apply (simp add: find_nu_measures_wellfounded)
  apply (simp add: find_nu_measures_decreases)
 apply (rule wp_intro)
apply (simp add: properties_lambda_gt_0)
done

text\<open>

This approach does not provide an upper bound on \<open>nu\<close> however.

@{cite "Harper:PiSML:2011"} observes (in his \S13.5.2) that if \<open>mu\<close> is zero then \<open>nu = lambda\<close>.

\<close>

lemma Harper:
  assumes "mu = 0"
  shows "\<lbrace>\<langle>True\<rangle>\<rbrace> find_nu \<lbrace>nu \<^bold>= \<langle>lambda\<rangle>\<rbrace>"
by (rule hoare_post_imp[OF find_nu]) (fastforce simp: assms dvd_def dest: lambda_dvd_nu)

subsection\<open> Finding \<open>mu\<close> \label{sec:th-finding-mu} \<close>

text\<open>

We recover \<open>mu\<close> from \<open>nu\<close> by exploiting the fact that
lambda divides @{term "nu"}: the Tortoise, reset to @{term "x0"}
and the Hare, both now moving at the same speed, will meet at @{term
"mu"}.

\<close>

lemma mu_nu:
  assumes si: "seq (i + i) = seq i"
  assumes j: "mu \<le> j"
  shows "seq (j + i) = seq j"
using lambda_dvd_nu[OF si] properties_loop[OF j]
by (clarsimp simp: dvd_def field_simps)

definition (in fx0) find_mu :: "'a state \<Rightarrow> 'a state" where
  "find_mu \<equiv>
    (\<lambda>s. s\<lparr> m := 0, tortoise := x0 \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> tortoise := f (tortoise s), hare := f (hare s), m := m s + 1 \<rparr>)"

lemma find_mu:
  "\<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> seq \<circ> (nu \<^bold>+ nu) \<^bold>= seq \<circ> nu \<^bold>\<and> hare \<^bold>= seq \<circ> nu\<rbrace>
     find_mu
   \<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> tortoise \<^bold>= \<langle>seq mu\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
apply (simp add: find_mu_def)
apply (rule hoare_pre)
 apply (rule whileI[where I="nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> seq \<circ> (nu \<^bold>+ nu) \<^bold>= seq \<circ> nu \<^bold>\<and> m \<^bold>\<le> \<langle>mu\<rangle>
                           \<^bold>\<and> tortoise \<^bold>= seq \<circ> m \<^bold>\<and> hare \<^bold>= seq \<circ> (m \<^bold>+ nu)"
                      and r="measure (\<langle>mu\<rangle> \<^bold>- m)"]
             wp_intro)+
    using properties_loops_ge_mu
    apply (force dest: mu_nu simp: less_eq_Suc_le[symmetric])
   apply simp
  apply (force dest: mu_nu simp: le_eq_less_or_eq)
 apply (rule wp_intro)
apply simp
done

subsection\<open> Finding \<open>lambda\<close> \<close>

text\<open>

With the Tortoise parked at @{term "mu"}, we find \<open>lambda\<close> by
walking the Hare around the loop.

\<close>

definition (in fx0) find_lambda :: "'a state \<Rightarrow> 'a state" where
  "find_lambda \<equiv>
    (\<lambda>s. s\<lparr> l := 1, hare := f (tortoise s) \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> hare := f (hare s), l := l s + 1 \<rparr>)"

lemma find_lambda:
  "\<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> tortoise \<^bold>= \<langle>seq mu\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>
     find_lambda
   \<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
apply (simp add: find_lambda_def)
apply (rule hoare_pre)
 apply (rule whileI[where I="nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> l \<^bold>\<in> \<langle>{0<..lambda}\<rangle>
                           \<^bold>\<and> tortoise \<^bold>= \<langle>seq mu\<rangle> \<^bold>\<and> hare \<^bold>= seq \<circ> (\<langle>mu\<rangle> \<^bold>+ l) \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>"
                      and r="measure (\<langle>lambda\<rangle> \<^bold>- l)"]
             wp_intro)+
    using properties_lambda_gt_0 properties_mod_lambda[where i="mu + lambda"] properties_distinct[where i=mu]
    apply (fastforce simp: less_eq_Suc_le[symmetric])
   apply simp
  using properties_mod_lambda[where i="mu + lambda"]
  apply (fastforce simp: le_eq_less_or_eq)
 apply (rule wp_intro)
using properties_lambda_gt_0
apply simp
done

subsection\<open> Top level \<close>

text\<open>

The complete program is simply the steps composed in order.

\<close>

definition (in fx0) tortoise_hare :: "'a state \<Rightarrow> 'a state" where
  "tortoise_hare \<equiv> find_nu ;; find_mu ;; find_lambda"

theorem tortoise_hare:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> tortoise_hare \<lbrace>nu \<^bold>\<in> \<langle>{0<..lambda + mu}\<rangle> \<^bold>\<and> l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
unfolding tortoise_hare_def
by (rule find_nu find_mu find_lambda wp_intro)+

end

corollary tortoise_hare_correct:
  assumes s': "s' = fx0.tortoise_hare f x arbitrary"
  shows "fx0.properties f x (l s') (m s')"
using assms properties.tortoise_hare[where f=f and ?x0.0=x]
by (fastforce intro: fx0.properties_existence[where f=f and ?x0.0=x]
               simp:  Basis.properties_def valid_def)

text\<open>

Isabelle can generate code from these definitions.

\<close>

schematic_goal tortoise_hare_code[code]:
  "fx0.tortoise_hare f x = ?code"
unfolding fx0.tortoise_hare_def fx0.find_nu_def fx0.find_mu_def fx0.find_lambda_def fcomp_assoc[symmetric] fcomp_comp
by (rule refl)

export_code fx0.tortoise_hare in SML
(*<*)

end
(*>*)


theory Pratt_Certificate
imports
  Complex_Main
  "../Lehmer/Lehmer"
begin

section {* Pratt's Primality Certificates *}
text_raw {* \label{sec:pratt} *}

text {*
  This work formalizes Pratt's proof system as described in his article
  ``Every Prime has a Succinct Certificate''\cite{pratt1975certificate}.
  The proof system makes use of two types of predicates:
  \begin{itemize}
    \item $\text{Prime}(p)$: $p$ is a prime number
    \item $(p, a, x)$: @{text "\<forall>q \<in> prime_factors(x). [a^((p - 1) div q) \<noteq> 1] (mod p)"}
  \end{itemize}
  We represent these predicates with the following datatype:
*}

datatype pratt = Prime nat | Triple nat nat nat

text {*
  Pratt describes an inference system consisting of the axiom $(p, a, 1)$
  and the following inference rules:
  \begin{itemize}
  \item R1: If we know that $(p, a, x)$ and @{text "[a^((p - 1) div q) \<noteq> 1] (mod p)"} hold for some
              prime number $q$ we can conclude $(p, a, qx)$ from that.
  \item R2: If we know that $(p, a, p - 1)$ and  @{text "[a^(p - 1) = 1] (mod p)"} hold, we can
              infer $\text{Prime}(p)$.
  \end{itemize}
  Both rules follow from Lehmer's theorem as we will show later on.

  A list of predicates (i.e., values of type @{type pratt}) is a \emph{certificate}, if it is
  built according to the inference system described above. I.e., a list @{term "x # xs :: pratt list"}
  is a certificate if @{term "xs :: pratt list"} is a certificate and @{term "x :: pratt"} is
  either an axiom or all preconditions of @{term "x :: pratt"} occur in @{term "xs :: pratt list"}.

  We call a certificate @{term "xs :: pratt list"} a \emph{certificate for @{term p}},
  if @{term "Prime p"} occurs in @{term "xs :: pratt list"}.

  The function @{text valid_cert} checks whether a list is a certificate.
*}

fun valid_cert :: "pratt list \<Rightarrow> bool" where
  "valid_cert [] = True"
| R2: "valid_cert (Prime p#xs) \<longleftrightarrow> 1 < p \<and> valid_cert xs
    \<and> (\<exists> a . [a^(p - 1) = 1] (mod p) \<and> Triple p a (p - 1) \<in> set xs)"
| R1: "valid_cert (Triple p a x # xs) \<longleftrightarrow> 0 < x  \<and> valid_cert xs \<and> (x=1 \<or>
    (\<exists>q y. x = q * y \<and> Prime q \<in> set xs \<and> Triple p a y \<in> set xs
      \<and> [a^((p - 1) div q) \<noteq> 1] (mod p)))"

text {*
  We define a function @{term size_cert} to measure the size of a certificate, assuming
  a binary encoding of numbers. We will use this to show that there is a certificate for a
  prime number $p$ such that the size of the certificate is polynomially bounded in the size
  of the binary representation of $p$.
*}
fun size_pratt :: "pratt \<Rightarrow> real" where
  "size_pratt (Prime p) = log 2 p" |
  "size_pratt (Triple p a x) = log 2 p + log 2 a + log 2 x"

fun size_cert :: "pratt list \<Rightarrow> real" where
  "size_cert [] = 0" |
  "size_cert (x # xs) = 1 + size_pratt x + size_cert xs"

section {* Soundness *}

text {*
  In Section \ref{sec:pratt} we introduced the predicates $\text{Prime}(p)$ and $(p, a, x)$.
  In this section we show that for a certificate every predicate occuring in this certificate
  holds. In particular, if $\text{Prime}(p)$ occurs in a certificate, $p$ is prime.
*}

lemma prime_factors_one[simp]: shows "prime_factors (Suc 0) = {}"
  by (auto simp add:prime_factors_altdef2_nat)

lemma prime_factors_prime: fixes p :: nat assumes "prime p" shows "prime_factors p = {p}"
proof
  have "0 < p" using assms by auto
  then show "{p} \<subseteq> prime_factors p" using assms by (auto simp add:prime_factors_altdef2_nat)
  { fix q assume "q \<in> prime_factors p"
    then have "q dvd p" "prime q" using `0<p` by (auto simp add:prime_factors_altdef2_nat)
    with assms have "q=p" by (auto simp: prime_nat_def)
    }
  then
  show "prime_factors p \<subseteq> {p}" by auto
qed

theorem pratt_sound:
  assumes 1: "valid_cert c"
  assumes 2: "t \<in> set c"
  shows "(t = Prime p \<longrightarrow> prime p) \<and>
         (t = Triple p a x \<longrightarrow> ((\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x))"
using assms
proof (induction c arbitrary: p a x t)
  case Nil then show ?case by force
  next
  case (Cons y ys)
  { assume "y=Triple p a x" "x=1"
    then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by simp
    }
  moreover
  { assume x_y: "y=Triple p a x" "x~=1"
    hence "x>0" using Cons.prems by auto
    obtain q z where "x=q*z" "Prime q \<in> set ys \<and> Triple p a z \<in> set ys"
               and cong:"[a^((p - 1) div q) \<noteq> 1] (mod p)" using Cons.prems x_y by auto
    then have factors_IH:"(\<forall> r \<in> prime_factors z . [a^((p - 1) div r) \<noteq> 1] (mod p))" "prime q" "z>0"
      using Cons.IH Cons.prems `x>0` `y=Triple p a x`
      by force+
    then have "prime_factors x = prime_factors z \<union> {q}"  using `x =q*z` `x>0`
      by (simp add:prime_factors_product_nat prime_factors_prime)
    then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0 < x"
      using factors_IH cong by (simp add: `x>0`)
    }
  ultimately have y_Triple:"y=Triple p a x \<Longrightarrow> (\<forall> q \<in> prime_factors x .
                                                [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by linarith
  { assume y: "y=Prime p" "p>2" then
    obtain a where a:"[a^(p - 1) = 1] (mod p)" "Triple p a (p - 1) \<in> set ys"
      using Cons.prems by auto
    then have Bier:"(\<forall>q\<in>prime_factors (p - 1). [a^((p - 1) div q) \<noteq> 1] (mod p))"
      using Cons.IH Cons.prems(1) by (simp add:y(1))
    then have "prime p" using lehmers_theorem[OF _ _a(1)] `p>2` by fastforce
    }
  moreover
  { assume "y=Prime p" "p=2" hence "prime p" by simp }
  moreover
  { assume "y=Prime p" then have "p>1"  using Cons.prems  by simp }
  ultimately have y_Prime:"y = Prime p \<Longrightarrow> prime p" by linarith

  show ?case
  proof (cases "t \<in> set ys")
    case True
      show ?thesis using Cons.IH[OF _ True] Cons.prems(1) by (cases y) auto
    next
    case False
      thus ?thesis using Cons.prems(2) y_Prime y_Triple by force
  qed
qed

section {* Completeness *}

text {*
  In this section we show completeness of Pratt's proof system, i.e., we show that for
  every prime number $p$ there exists a certificate for $p$. We also give an upper
  bound for the size of a minimal certificate

  The prove we give is constructive. We assume that we have certificates for all prime
  factors of $p - 1$ and use these to build a certificate for $p$ from that. It is
  important to note that certificates can be concatenated.
*}

lemma valid_cert_appendI:
  assumes "valid_cert r"
  assumes "valid_cert s"
  shows "valid_cert (r @ s)"
  using assms
proof (induction r)
  case (Cons y ys) then show ?case by (cases y) auto
qed simp

lemma valid_cert_concatI: "(\<forall>x \<in> set xs . valid_cert x) \<Longrightarrow> valid_cert (concat xs)"
  by (induction xs) (auto simp add: valid_cert_appendI)

lemma size_pratt_le:
 fixes d::real
 assumes "\<forall> x \<in> set c. size_pratt x \<le> d"
 shows "size_cert c \<le> length c * (1 + d)" using assms
 by (induction c) (simp_all add: real_of_nat_def algebra_simps)

fun build_fpc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> pratt list" where
  "build_fpc p a r [] = [Triple p a r]" |
  "build_fpc p a r (y # ys) = Triple p a r # build_fpc p a (r div y) ys"

text {*
  The function @{term build_fpc} helps us to construct a certificate for $p$ from
  the certificates for the prime factors of $p - 1$. Called as
  @{term "build_fpc p a (p - 1) qs"} where $@{term "qs"} = q_1 \ldots q_n$
  is prime decomposition of $p - 1$ such that $q_1 \cdot \dotsb \cdot q_n = @{term "p - 1 :: nat"}$,
  it returns the following list of predicates:
  \[
  (p,a,p-1), (p,a,\frac{p - 1}{q_1}), (p,a,\frac{p - 1}{q_1 q_2}), \ldots, (p,a,\frac{p-1}{q_1 \ldots q_n}) = (p,a,1)
  \]

  I.e., if there is an appropriate $a$ and and a certificate @{term rs} for all
  prime factors of $p$, then we can construct a certificate for $p$ as
  @{term [display] "Prime p # build_fpc p a (p - 1) qs @ rs"}
*}

text {*
  The following lemma shows that @{text "build_fpc"} extends a certificate that
  satisfies the preconditions described before to a correct certificate.
*}

lemma correct_fpc:
  assumes "valid_cert xs"
  assumes "listprod qs = r" "r \<noteq> 0"
  assumes "\<forall> q \<in> set qs . Prime q \<in> set xs"
  assumes "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)"
  shows "valid_cert (build_fpc p a r qs @ xs)"
  using assms
proof (induction qs arbitrary: r)
  case Nil thus ?case by auto
next
  case (Cons y ys)
  have "listprod ys = r div y" using Cons.prems by auto
  then have T_in: "Triple p a (listprod ys) \<in> set (build_fpc p a (r div y) ys @ xs)"
    by (cases ys) auto

  have "valid_cert (build_fpc p a (r div y) ys @ xs)"
    using Cons.prems by (intro Cons.IH) auto
  then have "valid_cert (Triple p a r # build_fpc p a (r div y) ys @ xs)"
    using `r \<noteq> 0` T_in Cons.prems by auto
  then show ?case by simp
qed

lemma length_fpc:
  "length (build_fpc p a r qs) = length qs + 1" by (induction qs arbitrary: r) auto

lemma div_gt_0:
  fixes m n :: nat assumes "m \<le> n" "0 < m" shows "0 < n div m"
proof -
  have "0 < m div m" using `0 < m` div_self by auto
  also have "m div m \<le> n div m" using `m \<le> n` by (rule div_le_mono)
  finally show ?thesis .
qed

lemma size_pratt_fpc:
  assumes "a \<le> p" "r \<le> p" "0 < a" "0 < r" "0 < p" "listprod qs = r"
  shows "\<forall>x \<in> set (build_fpc p a r qs) . size_pratt x \<le> 3 * log 2 p" using assms
proof (induction qs arbitrary: r)
  case Nil
  then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
  then show ?case by simp
next
  case (Cons q qs)
  then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
  then have  "log 2 a + log 2 r \<le> 2 * log 2 p" by arith
  moreover have "r div q > 0" using Cons.prems by (fastforce intro: div_gt_0)
  moreover hence "listprod qs = r div q" using Cons.prems(6) by auto
  moreover have "r div q \<le> p" using `r\<le>p` div_le_dividend[of r q] by linarith
  ultimately show ?case using Cons by simp
qed

lemma concat_set:
  assumes "\<forall> q \<in> qs . \<exists> c \<in> set cs . Prime q \<in> set c"
  shows "\<forall> q \<in> qs . Prime q \<in> set (concat cs)"
  using assms by (induction cs) auto

lemma p_in_prime_factorsE:
  fixes n :: nat
  assumes "p \<in> prime_factors n" "0 < n"
  obtains "2 \<le> p" "p \<le> n" "p dvd n" "prime p"
proof
  from assms show "prime p" by auto
  then show "2 \<le> p" by (auto dest: prime_gt_1_nat)

  from assms show "p dvd n" by (intro prime_factors_dvd_nat)
  then show "p \<le> n" using  `0 < n` by (rule dvd_imp_le)
qed

lemma prime_factors_list_prime:
  fixes n :: nat
  assumes "prime n"
  shows "\<exists> qs. prime_factors n = set qs \<and> listprod qs = n \<and> length qs = 1"
proof -
    have "prime_factors n = set [n]" using prime_factors_prime assms by force
    thus ?thesis by fastforce
qed

lemma prime_factors_list:
  fixes n :: nat assumes "3 < n" "\<not> prime n"
  shows "\<exists> qs. prime_factors n = set qs \<and> listprod qs = n \<and> length qs \<ge> 2"
  using assms
proof (induction n rule: less_induct)
  case (less n)
    obtain p where "p \<in> prime_factors n" using `n > 3` prime_factors_elem by force
    then have p':"2 \<le> p" "p \<le> n" "p dvd n" "prime p"
      using `3 < n` by (auto elim: p_in_prime_factorsE)
    { assume "n div p > 3" "\<not> prime (n div p)"
      then obtain qs
        where "prime_factors (n div p) = set qs" "listprod qs = (n div p)" "length qs \<ge> 2"
        using p' by atomize_elim (auto intro: less simp: div_gt_0)
      moreover
      have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
        using `3 < n` `2 \<le> p` `p \<le> n` `prime p`
      by (auto simp: prime_factors_product_nat div_gt_0 prime_factors_prime)
      ultimately
      have "prime_factors n = set (p # qs)" "listprod (p # qs) = n" "length (p#qs) \<ge> 2"
        using `p dvd n` by (simp_all add: dvd_mult_div_cancel)
      hence ?case by blast
    }
    moreover
    { assume "prime (n div p)"
      then obtain qs
        where "prime_factors (n div p) = set qs" "listprod qs = (n div p)" "length qs = 1"
        using prime_factors_list_prime by blast
      moreover
      have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
        using `3 < n` `2 \<le> p` `p \<le> n` `prime p`
      by (auto simp: prime_factors_product_nat div_gt_0 prime_factors_prime)
      ultimately
      have "prime_factors n = set (p # qs)" "listprod (p # qs) = n" "length (p#qs) \<ge> 2"
        using `p dvd n` by (simp_all add: dvd_mult_div_cancel)
      hence ?case by blast
    } note case_prime = this
    moreover
    { assume "n div p = 1"
      hence "n = p" using `n>3`  using One_leq_div[OF `p dvd n`] p'(2) by force
      hence ?case using `prime p` `\<not> prime n` by auto
    }
    moreover
    { assume "n div p = 2"
      hence ?case using case_prime by force
    }
    moreover
    { assume "n div p = 3"
      hence ?case using p' case_prime by force
    }
    ultimately show ?case using p' div_gt_0[of p n] case_prime by fastforce

qed

lemma listprod_ge:
  fixes xs::"nat list"
  assumes "\<forall> x \<in> set xs . x \<ge> 1"
  shows "listprod xs \<ge> 1" using assms by (induction xs) auto

lemma listsum_log:
  fixes b::real
  fixes xs::"nat list"
  assumes b: "b > 0" "b \<noteq> 1"
  assumes xs:"\<forall> x \<in> set xs . x \<ge> b"
  shows "(\<Sum>x\<leftarrow>xs. log b x) = log b (listprod xs)"
  using assms
proof (induction xs)
  case Nil
    thus ?case by simp
  next
  case (Cons y ys)
    have "real (listprod ys) > 0" using listprod_ge Cons.prems by fastforce
    thus ?case using log_mult[OF Cons.prems(1-2)] Cons by force
qed

lemma concat_length_le:
  fixes g :: "nat \<Rightarrow> real"
  assumes "\<forall> x \<in> set xs . real (length (f x)) \<le> g x"
  shows "length (concat (map f xs)) \<le> (\<Sum>x\<leftarrow>xs. g x)" using assms
  by (induction xs) force+

(* XXX move *)
lemma powr_realpow_numeral: "0 < x \<Longrightarrow> x powr (numeral n :: real) = x^(numeral n)"
  unfolding real_of_nat_numeral[symmetric] by (rule powr_realpow)

lemma prime_gt_3_impl_p_minus_one_not_prime:
  fixes p::nat
  assumes "prime p" "p>3"
  shows "\<not> prime (p - 1)"
proof
  assume "prime (p - 1)"
  have "\<not> even p" using assms by (simp add: prime_odd_nat)
  hence "2 dvd (p - 1)" by presburger
  hence "2 \<in> prime_factors (p - 1)" using `p>3` by (auto simp: prime_factors_altdef2_nat)
  thus False using prime_factors_prime `p>3` `prime (p - 1)` by auto
qed

text {*
  We now prove that Pratt's proof system is complete and derive upper bounds for
  the length and the size of the entries of a minimal certificate.
*}

theorem pratt_complete':
  assumes "prime p"
  shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> length c \<le> 6*log 2 p - 4 \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" using assms
proof (induction p rule: less_induct)
  case (less p)
  { assume [simp]: "p = 2"
    have "Prime p \<in> set [Prime 2, Triple 2 1 1]" by simp
    then have ?case by fastforce }
  moreover
  { assume [simp]: "p = 3"
    let ?cert = "[Prime 3, Triple 3 2 2, Triple 3 2 1, Prime 2, Triple 2 1 1]"

    have "length ?cert \<le> 6*log 2 p - 4
          \<longleftrightarrow> 2 powr 9 \<le> 2 powr (log 2 p * 6)" by auto
    also have "\<dots> \<longleftrightarrow> True"
      by (simp add: powr_powr[symmetric] powr_realpow_numeral)
    finally have ?case
      by (intro exI[where x="?cert"]) (simp add: cong_nat_def)
  }
  moreover
  { assume "p > 3"

    have "\<forall>q \<in> prime_factors (p - 1) . q < p" using `prime p`
      by (fastforce elim: p_in_prime_factorsE)
    hence factor_certs:"\<forall>q \<in> prime_factors (p - 1) . (\<exists>c . ((Prime q \<in> set c) \<and> (valid_cert c)
                                                      \<and> length c \<le> 6*log 2 q - 4) \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
      by (auto intro: less.IH)
    obtain a where a:"[a^(p - 1) = 1] (mod p) \<and> (\<forall> q. q \<in> prime_factors (p - 1)
              \<longrightarrow> [a^((p - 1) div q) \<noteq> 1] (mod p))" and a_size: "a > 0" "a < p"
      using converse_lehmer[OF `prime p`] by blast

    have "\<not> prime (p - 1)" using `p>3` prime_gt_3_impl_p_minus_one_not_prime `prime p` by auto
    have "p \<noteq> 4" using `prime p` by auto
    hence "p - 1 > 3" using `p > 3` by auto

    then obtain qs where prod_qs_eq:"listprod qs = p - 1"
        and qs_eq:"set qs = prime_factors (p - 1)" and qs_length_eq: "length qs \<ge> 2"
      using prime_factors_list[OF _ `\<not> prime (p - 1)`] by auto
    obtain f where f:"\<forall>q \<in> prime_factors (p - 1) . \<exists> c. f q = c
                     \<and> ((Prime q \<in> set c) \<and> (valid_cert c) \<and> length c \<le> 6*log 2 q - 4)
                     \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q)"
      using factor_certs by metis
    let ?cs = "map f qs"
    have cs: "\<forall>q \<in> prime_factors (p - 1) . (\<exists>c \<in> set ?cs . (Prime q \<in> set c) \<and> (valid_cert c)
                                           \<and> length c \<le> 6*log 2 q - 4
                                           \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
      using f qs_eq by auto

    have cs_cert_size: "\<forall>c \<in> set ?cs . \<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
    proof
      fix c assume "c \<in> set (map f qs)"
      then obtain q where "c = f q" and "q \<in> set qs" by auto
      hence *:"\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q" using f qs_eq by blast
      have "q < p" "q > 0" using `\<forall>q \<in> prime_factors (p - 1) . q < p` `q \<in> set qs` qs_eq by fast+
      show "\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
      proof
        fix x assume "x \<in> set c"
        hence "size_pratt x \<le> 3 * log 2 q" using * by fastforce
        also have "\<dots> \<le> 3 * log 2 p" using `q < p` `q > 0` `p > 3` by simp
        finally show "size_pratt x \<le> 3 * log 2 p" .
      qed
    qed

    have cs_valid_all: "\<forall>c \<in> set ?cs . valid_cert c"
      using f qs_eq by fastforce

    have "\<forall>x \<in> set (build_fpc p a (p - 1) qs). size_pratt x \<le> 3 * log 2 p"
      using cs_cert_size a_size `p > 3` prod_qs_eq by (intro size_pratt_fpc) auto
    hence "\<forall>x \<in> set (build_fpc p a (p - 1) qs @ concat ?cs) . size_pratt x \<le> 3 * log 2 p"
      using cs_cert_size by auto
    moreover
    have "Triple p a (p - 1) \<in> set (build_fpc p a (p - 1) qs @ concat ?cs)" by (cases qs) auto
    moreover
    have "valid_cert ((build_fpc p a (p - 1) qs)@ concat ?cs)"
    proof (rule correct_fpc)
      show "valid_cert (concat ?cs)"
        using cs_valid_all by (auto simp: valid_cert_concatI)
      show "listprod qs = p - 1" by (rule prod_qs_eq)
      show "p - 1 \<noteq> 0" using prime_gt_1_nat[OF `prime p`] by arith
      show "\<forall> q \<in> set qs . Prime q \<in> set (concat ?cs)"
        using concat_set[of "prime_factors (p - 1)"] cs qs_eq by blast
      show "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)" using qs_eq a by auto
    qed
    moreover
    { let ?k = "length qs"

      have qs_ge_2:"\<forall>q \<in> set qs . q \<ge> 2" using qs_eq
        by (simp add: prime_factors_prime_nat prime_ge_2_nat)

      have "\<forall>x\<in>set qs. real (length (f x)) \<le> 6 * log 2 (real x) - 4" using f qs_eq by blast
      hence "length (concat ?cs) \<le> (\<Sum>q\<leftarrow>qs. 6*log 2 q - 4)" using concat_length_le
        by fast
      hence "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
            \<le> ((\<Sum>q\<leftarrow>(map real qs). 6*log 2 q - 4) + ?k + 2)"
            by (simp add: o_def length_fpc)
      also have "\<dots> = (6*(\<Sum>q\<leftarrow>(map real qs). log 2 q) + (-4 * real ?k) + ?k + 2)"
        by (simp add: o_def listsum_subtractf listsum_triv real_of_nat_def listsum_const_mult)
      also have "\<dots> \<le> 6*log 2 (p - 1) - 4" using `?k\<ge>2` prod_qs_eq listsum_log[of 2 qs] qs_ge_2
        by force
      also have "\<dots> \<le> 6*log 2 p - 4" using log_le_cancel_iff[of 2 "p - 1" p] `p>3` by force
      ultimately have "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
                       \<le> 6*log 2 p - 4" by linarith }
    ultimately obtain c where c:"Triple p a (p - 1) \<in> set c" "valid_cert c"
                               "length (Prime p #c) \<le> 6*log 2 p - 4"
                               "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" by blast
    hence "Prime p \<in> set (Prime p # c)" "valid_cert (Prime p # c)"
         "(\<forall> x \<in> set (Prime p # c). size_pratt x \<le> 3 * log 2 p)"
    using a `prime p` by auto
    hence ?case using c by blast
  }
  moreover have "p\<ge>2" using less by (simp add: prime_ge_2_nat)
  ultimately show ?case using less by fastforce
qed

text {*
  We now recapitulate our results. A number $p$ is prime if and only if there
  is a certificate for $p$. Moreover, for a prime $p$ there always is a certificate
  whose size is polynomially bounded in the logarithm of $p$.
*}

corollary pratt:
  "prime p \<longleftrightarrow> (\<exists>c. Prime p \<in> set c \<and> valid_cert c)"
  using pratt_complete' pratt_sound(1) by blast

corollary pratt_size:
  assumes "prime p"
  shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> size_cert c \<le> (6 * log 2 p - 4) * (1 + 3 * log 2 p)"
proof -
  obtain c where c: "Prime p \<in> set c" "valid_cert c"
      and len: "length c \<le> 6*log 2 p - 4" and "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)"
    using pratt_complete' assms by blast
  hence "size_cert c \<le> length c * (1 + 3 * log 2 p)" by (simp add: size_pratt_le)
  also have "\<dots> \<le> (6*log 2 p - 4) * (1 + 3 * log 2 p)" using len by simp
  finally show ?thesis using c by blast
qed

end


section "Amortized Complexity (Unary Operations)"

theory Amortized_Framework0
imports Complex_Main
begin

text\<open>
This theory provides a simple amortized analysis framework where all operations
act on a single data type, i.e. no union-like operations. This is the basis of
the ITP 2015 paper by Nipkow. Although it is superseded by the model in
\<open>Amortized_Framework\<close> that allows arbitrarily many parameters, it is still
of interest because of its simplicity.\<close>

locale Amortized =
fixes init :: "'s"
fixes nxt :: "'o \<Rightarrow> 's \<Rightarrow> 's"
fixes inv :: "'s \<Rightarrow> bool"
fixes T :: "'o \<Rightarrow> 's \<Rightarrow> real"
fixes \<Phi> :: "'s \<Rightarrow> real"
fixes U :: "'o \<Rightarrow> 's \<Rightarrow> real"
assumes inv_init: "inv init"
assumes inv_nxt: "inv s \<Longrightarrow> inv(nxt f s)"
assumes ppos: "inv s \<Longrightarrow> \<Phi> s \<ge> 0"
assumes p0: "\<Phi> init = 0"
assumes U: "inv s \<Longrightarrow> T f s + \<Phi>(nxt f s) - \<Phi> s \<le> U f s"
begin

fun state :: "(nat \<Rightarrow> 'o) \<Rightarrow> nat \<Rightarrow> 's" where
"state f 0 = init" |
"state f (Suc n) = nxt (f n) (state f n)"

lemma inv_state: "inv(state f n)"
by(induction n)(simp_all add: inv_init inv_nxt)

definition A :: "(nat \<Rightarrow> 'o) \<Rightarrow> nat \<Rightarrow> real" where
"A f i = T (f i) (state f i) + \<Phi>(state f (i+1)) - \<Phi>(state f i)"

lemma aeq: "(\<Sum>i<n. T (f i) (state f i)) = (\<Sum>i<n. A f i) - \<Phi>(state f n)"
apply(induction n)
apply (simp add: p0)
apply (simp add: A_def)
done

corollary TA: "(\<Sum>i<n. T (f i) (state f i)) \<le> (\<Sum>i<n. A f i)"
by (metis add.commute aeq diff_add_cancel le_add_same_cancel2 ppos[OF inv_state])

lemma aa1: "A f i \<le> U (f i) (state f i)"
by(simp add: A_def U inv_state)

lemma ub: "(\<Sum>i<n. T (f i) (state f i)) \<le> (\<Sum>i<n. U (f i) (state f i))"
by (metis (mono_tags) aa1 order.trans sum_mono TA)

end

subsection "Binary Counter"

locale BinCounter
begin

fun incr where
"incr [] = [True]" |
"incr (False#bs) = True # bs" |
"incr (True#bs) = False # incr bs"

fun T_incr :: "bool list \<Rightarrow> real" where
"T_incr [] = 1" |
"T_incr (False#bs) = 1" |
"T_incr (True#bs) = T_incr bs + 1"

definition \<Phi> :: "bool list \<Rightarrow> real" where
"\<Phi> bs = length(filter id bs)"

lemma A_incr: "T_incr bs + \<Phi>(incr bs) - \<Phi> bs = 2"
apply(induction bs rule: incr.induct)
apply (simp_all add: \<Phi>_def)
done

interpretation incr: Amortized
where init = "[]" and nxt = "%_. incr" and inv = "\<lambda>_. True"
and T = "\<lambda>_. T_incr" and \<Phi> = \<Phi> and U = "\<lambda>_ _. 2"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case 3 show ?case by(simp add: \<Phi>_def)
next
  case 4 show ?case by(simp add: \<Phi>_def)
next
  case 5 show ?case by(simp add: A_incr)
qed

thm incr.ub

end

subsection "Dynamic tables: insert only"

locale DynTable1
begin

fun ins :: "nat*nat \<Rightarrow> nat*nat" where
"ins (n,l) = (n+1, if n<l then l else if l=0 then 1 else 2*l)"

fun T_ins :: "nat*nat \<Rightarrow> real" where
"T_ins (n,l) = (if n<l then 1 else n+1)"

fun invar :: "nat*nat \<Rightarrow> bool" where
"invar (n,l) = (l/2 \<le> n \<and> n \<le> l)"

fun \<Phi> :: "nat*nat \<Rightarrow> real" where
"\<Phi> (n,l) = 2*(real n) - l"

interpretation ins: Amortized
where init = "(0::nat,0::nat)"
and nxt = "\<lambda>_. ins"
and inv = invar
and T = "\<lambda>_. T_ins" and \<Phi> = \<Phi> and U = "\<lambda>_ _. 3"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s) thus ?case by(cases s) auto
next
  case (3 s) thus ?case by(cases s)(simp split: if_splits)
next
  case 4 show ?case by(simp)
next
  case (5 s) thus ?case by(cases s) auto
qed

end

locale table_insert = DynTable1 +
fixes a :: real
fixes c :: real
assumes c1[arith]: "c > 1"
assumes ac2: "a \<ge> c/(c - 1)"
begin

lemma ac: "a \<ge> 1/(c - 1)"
using ac2 by(simp add: field_simps)

lemma a0[arith]: "a>0"
proof-
  have "1/(c - 1) > 0" using ac by simp
  thus ?thesis by (metis ac dual_order.strict_trans1)
qed

definition "b = 1/(c - 1)"

lemma b0[arith]: "b > 0"
using ac by (simp add: b_def)

fun "ins" :: "nat * nat \<Rightarrow> nat * nat" where
"ins(n,l) = (n+1, if n<l then l else if l=0 then 1 else nat(ceiling(c*l)))"

fun pins :: "nat * nat => real" where
"pins(n,l) = a*n - b*l"

interpretation ins: Amortized
where init = "(0,0)" and nxt = "%_. ins"
and inv = "\<lambda>(n,l). if l=0 then n=0 else n \<le> l \<and> (b/a)*l \<le> n"
and T = "\<lambda>_. T_ins" and \<Phi> = pins and U = "\<lambda>_ _. a + 1"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s)
  show ?case
  proof (cases s)
    case [simp]: (Pair n l)
    show ?thesis
    proof cases
      assume "l=0" thus ?thesis using 2 ac
        by (simp add: b_def field_simps)
    next
      assume "l\<noteq>0"
      show ?thesis
      proof cases
        assume "n<l"
        thus ?thesis using 2 by(simp add: algebra_simps)
      next
        assume "\<not> n<l"
        hence [simp]: "n=l" using 2 \<open>l\<noteq>0\<close> by simp
        have 1: "(b/a) * ceiling(c * l) \<le> real l + 1"
        proof-
          have "(b/a) * ceiling(c * l) = ceiling(c * l)/(a*(c - 1))"
            by(simp add: b_def)
          also have "ceiling(c * l) \<le> c*l + 1" by simp
          also have "\<dots> \<le> c*(real l+1)" by (simp add: algebra_simps)
          also have "\<dots> / (a*(c - 1)) = (c/(a*(c - 1))) * (real l + 1)" by simp
          also have "c/(a*(c - 1)) \<le> 1" using ac2 by (simp add: field_simps)
          finally show ?thesis by (simp add: divide_right_mono)
        qed
        have 2: "real l + 1 \<le> ceiling(c * real l)"
        proof-
          have "real l + 1 = of_int(int(l)) + 1" by simp
          also have "... \<le> ceiling(c * real l)" using \<open>l \<noteq> 0\<close>
            by(simp only: int_less_real_le[symmetric] less_ceiling_iff)
              (simp add: mult_less_cancel_right1)
          finally show ?thesis .
        qed
        from \<open>l\<noteq>0\<close> 1 2 show ?thesis by simp (simp add: not_le zero_less_mult_iff)
      qed
    qed
  qed
next
  case (3 s) thus ?case by(cases s)(simp add: field_simps split: if_splits)
next
  case 4 show ?case by(simp)
next
  case (5 s)
  show ?case
  proof (cases s)
    case [simp]: (Pair n l)
    show ?thesis
    proof cases
      assume "l=0" thus ?thesis using 5 by (simp)
    next
      assume [arith]: "l\<noteq>0"
      show ?thesis
      proof cases
        assume "n<l"
        thus ?thesis using 5 ac by(simp add: algebra_simps b_def)
      next
        assume "\<not> n<l"
        hence [simp]: "n=l" using 5 by simp
        have "T_ins s + pins (ins s) - pins s = l + a + 1 + (- b*ceiling(c*l)) + b*l"
          using \<open>l\<noteq>0\<close>
          by(simp add: algebra_simps less_trans[of "-1::real" 0])
        also have "- b * ceiling(c*l) \<le> - b * (c*l)" by (simp add: ceiling_correct)
        also have "l + a + 1 + - b*(c*l) + b*l = a + 1 + l*(1 - b*(c - 1))"
          by (simp add: algebra_simps)
        also have "b*(c - 1) = 1" by(simp add: b_def)
        also have "a + 1 + (real l)*(1 - 1) = a+1" by simp
        finally show ?thesis by simp
      qed
    qed
  qed
qed

thm ins.ub

end

subsection "Stack with multipop"

datatype 'a op\<^sub>s\<^sub>t\<^sub>k = Push 'a | Pop nat

fun nxt_stk :: "'a op\<^sub>s\<^sub>t\<^sub>k \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"nxt_stk (Push x) xs = x # xs" |
"nxt_stk (Pop n) xs = drop n xs"

fun T_stk :: "'a op\<^sub>s\<^sub>t\<^sub>k \<Rightarrow> 'a list \<Rightarrow> real" where
"T_stk (Push x) xs = 1" |
"T_stk (Pop n) xs = min n (length xs)"

interpretation stack: Amortized
where init = "[]" and nxt = nxt_stk and inv = "\<lambda>_. True"
and T = T_stk and \<Phi> = "length" and U = "\<lambda>f _. case f of Push _ \<Rightarrow> 2 | Pop _ \<Rightarrow> 0"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s) thus ?case by(cases s) auto
next
  case 3 thus ?case by simp
next
  case 4 show ?case by(simp)
next
  case (5 _ f) thus ?case by (cases f) auto
qed

subsection "Queue"

text\<open>See, for example, the book by Okasaki~\<^cite>\<open>"Okasaki"\<close>.\<close>

datatype 'a op\<^sub>q = Enq 'a | Deq

type_synonym 'a queue = "'a list * 'a list"

fun nxt_q :: "'a op\<^sub>q \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
"nxt_q (Enq x) (xs,ys) = (x#xs,ys)" |
"nxt_q Deq (xs,ys) = (if ys = [] then ([], tl(rev xs)) else (xs,tl ys))"

fun T_q :: "'a op\<^sub>q \<Rightarrow> 'a queue \<Rightarrow> real" where
"T_q (Enq x) (xs,ys) = 1" |
"T_q Deq (xs,ys) = (if ys = [] then length xs else 0)"

interpretation queue: Amortized
where init = "([],[])" and nxt = nxt_q and inv = "\<lambda>_. True"
and T = T_q and \<Phi> = "\<lambda>(xs,ys). length xs" and U = "\<lambda>f _. case f of Enq _ \<Rightarrow> 2 | Deq \<Rightarrow> 0"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s) thus ?case by(cases s) auto
next
  case (3 s) thus ?case by(cases s) auto
next
  case 4 show ?case by(simp)
next
  case (5 s f) thus ?case
    apply(cases s)
    apply(cases f)
    by auto
qed

fun balance :: "'a queue \<Rightarrow> 'a queue" where
"balance(xs,ys) = (if size xs \<le> size ys then (xs,ys) else ([], ys @ rev xs))"

fun nxt_q2 :: "'a op\<^sub>q \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
"nxt_q2 (Enq a) (xs,ys) = balance (a#xs,ys)" |
"nxt_q2 Deq (xs,ys) = balance (xs, tl ys)"

fun T_q2 :: "'a op\<^sub>q \<Rightarrow> 'a queue \<Rightarrow> real" where
"T_q2 (Enq _) (xs,ys) = 1 + (if size xs + 1 \<le> size ys then 0 else size xs + 1 + size ys)" |
"T_q2 Deq (xs,ys) = (if size xs \<le> size ys - 1 then 0 else size xs + (size ys - 1))"

interpretation queue2: Amortized
where init = "([],[])" and nxt = nxt_q2
and inv = "\<lambda>(xs,ys). size xs \<le> size ys"
and T = T_q2 and \<Phi> = "\<lambda>(xs,ys). 2 * size xs"
and U = "\<lambda>f _. case f of Enq _ \<Rightarrow> 3 | Deq \<Rightarrow> 0"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s f) thus ?case by(cases s) (cases f, auto)
next
  case (3 s) thus ?case by(cases s) auto
next
  case 4 show ?case by(simp)
next
  case (5 s f) thus ?case
    apply(cases s)
    apply(cases f)
    by (auto simp: split: prod.splits)
qed

subsection "Dynamic tables: insert and delete"

datatype op\<^sub>t\<^sub>b = Ins | Del

locale DynTable2 = DynTable1
begin

fun del :: "nat*nat \<Rightarrow> nat*nat" where
"del (n,l) = (n - 1, if n=1 then 0 else if 4*(n - 1)<l then l div 2 else l)"

fun T_del :: "nat*nat \<Rightarrow> real" where
"T_del (n,l) = (if n=1 then 1 else if 4*(n - 1)<l then n else 1)"

fun nxt_tb :: "op\<^sub>t\<^sub>b \<Rightarrow> nat*nat \<Rightarrow> nat*nat" where
"nxt_tb Ins = ins" |
"nxt_tb Del = del"

fun T_tb :: "op\<^sub>t\<^sub>b \<Rightarrow> nat*nat \<Rightarrow> real" where
"T_tb Ins = T_ins" |
"T_tb Del = T_del"

fun invar :: "nat*nat \<Rightarrow> bool" where
"invar (n,l) = (n \<le> l)"

fun \<Phi> :: "nat*nat \<Rightarrow> real" where
"\<Phi> (n,l) = (if n < l/2 then l/2 - n else 2*n - l)"

interpretation tb: Amortized
where init = "(0,0)" and nxt = nxt_tb
and inv = invar
and T = T_tb and \<Phi> = \<Phi>
and U = "\<lambda>f _. case f of Ins \<Rightarrow> 3 | Del \<Rightarrow> 2"
proof (standard, goal_cases)
  case 1 show ?case by auto
next
  case (2 s f) thus ?case by(cases s, cases f) (auto)
next
  case (3 s) show ?case by(cases s)(simp)
next
  case 4 show ?case by(simp)
next
  case (5 s f) thus ?case apply(cases s) apply(cases f)
    by (auto)
qed

end

end