section \<open> Encoding real numbers as bit sequences \<close>

theory Real_Bit
imports
  HOL.Transcendental
  "HOL-Library.Z2"
  "HOL-Library.Sublist"
  Dyadic
begin

text \<open> The objective of this theory is to show how every real number can be encoded as an infinite
  sequences of bits. Whilst being an interesting property in its own right, this in particular
  means that we can show that the real numbers can be encoded as a a set of natural numbers
  (i.e. a function of type @{typ "nat \<Rightarrow> bool"} -- a bit sequence), and thus have the same
  cardinality. \<close>

declare [[linarith_split_limit=12]]

definition bits_to_nats :: "(nat \<Rightarrow> bit) \<Rightarrow> nat set" where
"bits_to_nats f = {x. f x = 1}"

lemma bij_bits_to_nats: "bij bits_to_nats"
  apply (rule bijI)
   apply (rule injI)
   apply (simp add: bits_to_nats_def set_eq_iff)
  apply (rule ext)
  apply (rename_tac x y i)
  apply (case_tac "x i", auto)
  apply (metis bit.exhaust)
  apply (simp add: image_def bits_to_nats_def)
  apply (rename_tac x)
  apply (rule_tac x="\<lambda> i. if (i \<in> x) then 1 else 0" in exI)
  apply (auto)
  done

lemma card_of_bit_seq: "|UNIV :: (nat \<Rightarrow> bit) set| =o |UNIV :: nat set set|"
  using bij_bits_to_nats card_of_ordIsoI by blast

lemma uncountable_UNIV_nat_set: "uncountable (UNIV :: nat set set)"
  by (auto simp add: uncountable_def, metis Cantors_paradox Pow_UNIV)

lemma card_rat_less_nat_set: "|\<rat> :: real set| <o |UNIV :: nat set set|"
proof -
  have "countable (\<rat> :: real set)"
    by (simp add: countable_rat)
  moreover have "uncountable (UNIV :: nat set set)"
    by (simp add: uncountable_UNIV_nat_set)
  ultimately show ?thesis
    by (metis card_of_ordLess2 countable_empty countable_image)
qed

definition terminates_at :: "(nat \<Rightarrow> 'a::zero) \<Rightarrow> nat \<Rightarrow> bool" where
"terminates_at x i = (\<forall> j \<ge> i. x(j) = 0)"

definition terminal :: "(nat \<Rightarrow> 'a::zero) \<Rightarrow> bool" where
"terminal x = (\<exists> i. terminates_at x i)"

abbreviation "BitSeqs \<equiv> (UNIV :: (nat \<Rightarrow> bit) set)"

abbreviation "TermSeqs \<equiv> {x. terminal x}"

abbreviation "TermBitSeqs \<equiv> TermSeqs :: (nat \<Rightarrow> bit) set"

abbreviation "nonterminal x \<equiv> \<not> terminal x"

abbreviation "NonTermSeqs \<equiv> {x. nonterminal x}"

abbreviation "NonTermBitSeqs \<equiv> NonTermSeqs :: (nat \<Rightarrow> bit) set"

definition subsequence :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" where
"subsequence n x = (\<lambda> i. x (i + n))"

definition recur :: "('a list) \<Rightarrow> (nat \<Rightarrow> 'a)" where
"recur xs = (\<lambda> i. xs ! (i mod (length xs)))"

lemma recur_example: "recur [x,y] i = (if even i then x else y)"
  apply (auto simp add: recur_def)
  apply (simp add: numeral_2_eq_2)
  apply (metis One_nat_def even_iff_mod_2_eq_zero not_mod_2_eq_0_eq_1 nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
done

definition recurrent :: "(nat \<Rightarrow> bit) \<Rightarrow> bool" where
"recurrent x = (\<exists> n xs. subsequence n x = recur xs)"

lemma recurrent_recur: "recurrent (recur xs)"
  apply (auto simp add: recurrent_def recur_def subsequence_def)
  apply (rule_tac x="0" in exI)
  apply (rule_tac x="xs" in exI)
  apply (auto)
done

text \<open> Convert a binary representation to a real number in [0..1] \<close>

definition binlist :: "bit list \<Rightarrow> real" where
"binlist xs = (\<Sum> i<length xs. of_bit(xs!i)/2^(i+1))"

lemma Ints_of_bit: "of_bit x \<in> \<int>"
  by (cases "x", simp_all)

lemma dyadic_bin_list: "dyadic (binlist xs)"
  apply (unfold binlist_def)
  apply (rule dyadic_sum)
  apply (blast)
  apply (blast intro: Ints_of_bit dyadic_div_pow_2)
done

(*
lemma "bij_betw binlist {xs. length xs > 0 \<longrightarrow> last xs = 1} \<rat>\<^sub>D"
  apply (rule bij_betwI')
*)

text \<open> For real number x, calculate the nth binary digit, given all the bits from 0..n-1 \<close>

definition rbit :: "real \<Rightarrow> nat \<Rightarrow> bit list \<Rightarrow> bit" where
  "rbit x n xs = of_int \<lfloor>(x - binlist xs) * 2^(n+2)\<rfloor>"

text \<open> Convert a real number in the range [0..1) to a sequence of binary digits \<close>

text \<open> Extract the nth bit of a real number by shifting it to the left n+1 places (power multiplication),
        chopping off the fractional part (flooring it), and removing all but the first bit of
        the integer part (by takes modulus 2). \<close>

definition rbseq :: "real \<Rightarrow> (nat \<Rightarrow> bit)" where
"rbseq x = (\<lambda> i.  of_int (\<lfloor>(x * (2 ^ (i+1)))\<rfloor> mod 2))"

lemma of_drat_DFract: "coprime a (2^b) \<Longrightarrow> of_drat (DFract a b) = a / 2^b"
  by (transfer, auto simp add: quotient_of_Fract of_int_power)

definition real_bits2 :: "real \<Rightarrow> nat \<Rightarrow> bit list" where
"real_bits2 x n = map (rbseq x) [0..<n+1]"

fun real_bits :: "real \<Rightarrow> nat \<Rightarrow> bit list" where
"real_bits x 0 = [of_int \<lfloor>x * 2\<rfloor>]" |
"real_bits x (Suc n) =
   (real_bits x n @ [rbit x n (real_bits x n)])"

definition drat_bits :: "drat \<Rightarrow> bit list" where
"drat_bits x = real_bits (of_drat x) (snd (dfrac_of x))"

(* Produce version that produces a non-terminating number for dyadics *)

definition real_bin :: "real \<Rightarrow> (nat \<Rightarrow> bit)" where
"real_bin x = (\<lambda> n. (real_bits x n) ! n)"

definition real_bin_seq :: "real \<Rightarrow> (nat \<Rightarrow> bool)" where
"real_bin_seq x n = (last (real_bits x n) = 1)"

definition binseq :: "(nat \<Rightarrow> bit) \<Rightarrow> (nat \<Rightarrow> real)" where
"binseq x = (\<lambda> i. of_bit (x(i)) / 2^(i+1))"

definition bin_real :: "(nat \<Rightarrow> bit) \<Rightarrow> real" where
"bin_real x = (\<Sum> i. binseq x i)"

lemma binseq_le_bin_series: "(\<Sum> i<n. binseq x i) \<le> (\<Sum> i<n. 1/2^i)"
  apply (rule sum_mono)
  apply (rename_tac i)
  apply (simp add: binseq_def)
  apply (case_tac "x i")
  apply (auto simp add: frac_le)
done

lemma bin_series_geometric:
  "((\<Sum> i\<le>n. 1/2^(i+1)) :: rat) = 1 - (1 / 2^(n + 1))"
proof -
  have "((\<Sum> i\<le>n. 1/2^(i+1)) :: rat) = (\<Sum> i<n+2. (1/2)^i) - 1"
    by (induct n, simp_all add: power_one_over)
  also have "... = 1 - (1 / 2^(n + 1))"
    by (subst geometric_sum, simp_all add: power_one_over)
  finally show ?thesis .
qed

lemma binseq_pos: "binseq x i \<ge> 0"
  by (case_tac "x i", simp_all add: binseq_def)

lemma sum_minus_triv:
  fixes f :: "nat \<Rightarrow> 'b::ab_group_add"
  assumes "n \<ge> m"
  shows "(\<Sum>i\<le>n. f(i)) - (\<Sum>i\<le>m. f(i)) = (\<Sum>i=m+1..n. f(i))"
proof -
  have "{..n} - {..m} = {m + 1..n}"
    by auto
  with assms show ?thesis
    by (simp add: sum_diff[THEN sym])
qed

lemma binary_ub:
  assumes "n \<ge> m"
  shows "((1 / 2 ^ m) :: real) > (\<Sum>i=m+1..n. 1 / 2 ^ i)"
proof -
  from assms have "((\<Sum>i=m+1..n. 1 / 2 ^ i) :: real) = (\<Sum>i<n+1. 1/2^i) - (\<Sum>i<m+1. 1/2^i)"
    by (subst sum_minus_triv[THEN sym], simp_all add: lessThan_Suc_atMost)
  also have "... = (\<Sum>i<n+1. (1/2)^i) - (\<Sum>i<m+1. (1/2)^i)"
    by (simp add: power_one_over)
  also have "... = 2 / 2 ^ (m + 1) - 2 / 2 ^ (n + 1)"
    by (simp only: geometric_sum, simp add: power_one_over)
  moreover have "(1/2^m :: real) > 2 / 2 ^ (m + 1) - 2 / 2 ^ (n + 1)"
    by (auto)
  ultimately show ?thesis
    by linarith
qed

lemma real_bin_ub:
  assumes "m > 0"
  shows "\<exists> n. 2^n > (m::real)"
proof -
  have "m \<le> \<lceil>m\<rceil>"
    by (simp add: le_of_int_ceiling)
  moreover from assms have "2 powr \<lceil>log 2 \<lceil>m\<rceil>\<rceil> \<ge> \<lceil>m\<rceil>"
    by (subst log_le_iff[THEN sym], simp_all)
  moreover from assms have "2 powr \<lceil>log 2 \<lceil>m\<rceil>\<rceil> = 2 powr (real (nat (\<lceil>log 2 \<lceil>m\<rceil>\<rceil> :: int)))"
  proof -
    from assms have "log 2 \<lceil>m\<rceil> \<ge> 0"
      by simp
    thus ?thesis
      by simp
  qed
  ultimately have "2 ^ nat \<lceil>log 2 \<lceil>m\<rceil>\<rceil> \<ge> m"
    by (metis order_trans powr_realpow zero_less_numeral)
  with assms have "2 ^ (nat \<lceil>log 2 \<lceil>m\<rceil>\<rceil> + 1) > m"
    by simp
  thus ?thesis
    by blast
qed

lemma real_bin_lower_bound:
  assumes "(m::real) > 0"
  shows "\<exists> n::nat. 1 / 2^n < m"
proof -
  from assms obtain n where "2^n > (1/m)"
    using real_bin_ub[of "1/m"] by auto
  with assms have "1/2^n < 1/(1/m)"
    by (subst frac_less2, auto)
  thus ?thesis
    by (rule_tac x="n" in exI, auto)
qed

theorem binseq_summable: "summable (binseq x)"
proof (simp add: summable_Cauchy, clarify)
  fix r :: real
  assume "r > 0"
  then obtain j where wits: "1/2^j < r"
    using real_bin_lower_bound[of "r"] by auto
  then show "\<exists>k. \<forall>m\<ge>k. \<forall>n. \<bar>sum (binseq x) {m..<n}\<bar> < r"
  proof (rule_tac x="j+1" in exI, clarify)
    fix m n :: nat
    assume mnassm: "j+1 \<le> m"
    have "(\<Sum> i=m..<n. binseq x i) \<le> 1/2^j"
    proof -
      have "(\<Sum> i=m..<n. binseq x i) \<le> (\<Sum>i=m..<n. 1/2^i)"
        by (rule sum_mono)
           (simp add: binseq_def frac_le)
      also from mnassm have "... \<le> (\<Sum>i=j+1..n-1. 1/2^i)"
        by (auto intro!: sum_mono2)
      also have "... < 1/2^j"
      proof (cases "j \<le> n - 1")
        case True thus ?thesis
          by (rule binary_ub)
      next
        case False thus ?thesis
          by auto
      qed
      finally show ?thesis by auto
    qed
    with mnassm wits show "\<bar>sum (binseq x) {m..<n}\<bar> < r"
      by (auto simp add: sum_minus_triv binseq_pos sum_nonneg)
  qed
qed

lemma binlist_nil [simp]:
  "binlist [] = 0"
  by (simp add: binlist_def)

lemma binlist_append [simp]:
  "binlist (xs @ [x]) = binlist xs + (of_bit x*(1/2^(length xs + 1)))"
  by (simp add: binlist_def nth_append)

lemma of_bit_pos: "of_bit x \<ge> (0::real)"
  by (cases x, auto)

lemma bit_real_pos: "of_bit x * (1/2^n) \<ge> (0::real)"
proof -
  have "of_bit x \<ge> (0::real)"
    by (cases x, auto)
  moreover have "1/2^n \<ge> (0::real)"
    by auto
  ultimately show ?thesis
    by auto
qed

lemma binlist_pos [simp]:
  "binlist xs \<ge> 0"
  by (induct xs rule: rev_induct, auto simp add: of_bit_pos)

lemma real_bits_length [simp]:
  "length (real_bits x n) = n + 1"
  by (induct n, simp_all)

lemma real_bits_first [simp]:
  "real_bits x m ! 0 = of_int \<lfloor>x * 2\<rfloor>"
  by (induct m, simp_all add: nth_append)

lemma real_bits_plus:
  assumes "i \<le> m"
  shows "real_bits x (m + k) ! i = real_bits x m ! i"
  using assms
  by (induct k, auto simp add: nth_append)

lemma prefix_nth:
  "\<lbrakk> length xs \<le> length ys; \<forall> i < length xs. xs!i = ys!i \<rbrakk> \<Longrightarrow> prefix xs ys"
proof (induct xs arbitrary: ys)
  case Nil thus ?case by auto
next
  case (Cons x xs') note hyp = this
  then obtain ys' where "ys = x # ys'"
    by (metis Cons_prefix_Cons in_set_takeD list.set_cases list.set_intros(1) nth_take_lemma order_refl take_all take_is_prefix)
  with hyp show ?case
    by (auto, metis le_trans not_less not_less_eq_eq not_less_iff_gr_or_eq nth_Cons_Suc)
qed

lemma real_bits_prefix:
  assumes "m \<le> n"
  shows "prefix (real_bits x m) (real_bits x n)"
proof -
  obtain k where "n = m + k"
    by (metis assms le_add_diff_inverse)
  thus ?thesis
    by (auto intro: prefix_nth simp add: real_bits_plus)
qed

lemma binseq_rbseq: "binseq (rbseq x) i = (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1))"
  by (simp add: binseq_def rbseq_def)
     (metis not_mod_2_eq_1_eq_0 of_int_0 of_int_1)

text \<open> The contribution of the nth bit to a real number \<close>

definition nth_cont :: "real \<Rightarrow> nat \<Rightarrow> real" where
"nth_cont x i = \<lfloor>x * (2^(i+1))\<rfloor> mod 2 / (2^(i+1))"

text \<open> Every bit contribution is less than the whole \<close>

lemma nth_cont_cases [case_names zero nzero]:
  "\<lbrakk> nth_cont x i = 0 \<Longrightarrow> P; nth_cont x i = 1/2^(i+1) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (simp add: nth_cont_def)
  apply (cases "\<lfloor>x * (2 * 2 ^ i)\<rfloor>" rule: parity_cases)
  apply (simp_all)
done

lemma nth_cont_le_geometric:
  "(\<Sum> i\<le>n. nth_cont x i) \<le> 1 - (1 / 2^(n + 1))"
proof -
  have "(\<Sum> i\<le>n. nth_cont x i) \<le> (\<Sum> i\<le>n. 1 / (2^(i+1)))"
    by (rule sum_mono, metis nth_cont_cases order_refl zero_le_divide_1_iff zero_le_numeral zero_le_power)
  also have "... = (\<Sum> i<n+2. (1/2)^i) - 1"
    by (induct n, simp_all add: power_one_over)
  also have "... = 1 - (1 / 2^(n + 1))"
    by (subst geometric_sum, simp_all add: power_one_over)
  finally show ?thesis .
qed

lemma nth_cont_bit_diff_ge_zero:
  assumes "0 \<le> x" "x < 1"
  shows "0 \<le> x - nth_cont x i"
proof (cases "\<lfloor>x * (2 ^ (i+1))\<rfloor>" rule: parity_cases)
  case even
  with assms show ?thesis by (simp add: nth_cont_def)
next
  case odd
  have "\<lfloor>x * (2 ^ (i+1))\<rfloor> \<ge> 0"
    by (simp add: assms(1))
  with odd have "\<lfloor>x * (2 ^ (i+1))\<rfloor> \<ge> (1::int)"
    by (metis zmod_le_nonneg_dividend)
  with odd show ?thesis
    by (simp add: nth_cont_def pos_divide_le_eq)
qed

lemma bin_series_geometric':
  "((\<Sum> i\<le>n. 1/2^(i+1)) :: real) = 1 - (1 / 2^(n + 1))"
proof -
  have "((\<Sum> i\<le>n. 1/2^(i+1)) :: real) = (\<Sum> i<n+2. (1/2)^i) - 1"
    by (induct n, simp_all add: power_one_over)
  also have "... = 1 - (1 / 2^(n + 1))"
    by (subst geometric_sum, simp_all add: power_one_over)
  finally show ?thesis .
qed

text \<open> The removal of the (contribution of) the ith bit from a real number does not affect
        the jth bit. \<close>

lemma nth_cont_removed:
  "nth_cont (x - nth_cont x i) i = 0"
proof -
  have "(x - 1 / (2 * 2 ^ i)) * (2 * 2 ^ i) = x * (2 * 2 ^ i) - 1"
  proof -
    have "(x - 1 / (2 * 2 ^ i)) * (2 * 2 ^ i) = (x*(2 * 2 ^ i) - (1 / (2 * 2 ^ i))*(2 * 2 ^ i))"
      using left_diff_distrib by blast
    also have "... = x * (2 * 2 ^ i) - 1"
      by (simp)
    finally show ?thesis .
  qed
  thus ?thesis
    apply (simp add: nth_cont_def)
    apply (cases "\<lfloor>x * (2 * 2 ^ i)\<rfloor>" rule: parity_cases)
    apply (simp_all)
  done
qed

lemma nth_cont_indep1:
  assumes "i < j"
  shows "nth_cont (x - nth_cont x i) j = nth_cont x j"
proof -
  have "(x - (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1))) * (2 ^ (j+1)) =
        (x * 2 ^ (j+1)) - ((\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1)) * (2 ^ (j+1)))"
    using left_diff_distrib by blast
  moreover have "x * (2 * 2 ^ j) - 2 ^ j / 2 ^ i = x * (2 * 2 ^ j) - real ((2::nat) ^ (j - i))"
    by (simp add: assms order_less_imp_le power_diff power_one_over)
       (metis assms le_less of_nat_numeral of_nat_power power_diff rel_simps(76))
  moreover have "\<lfloor>x * (2 * 2 ^ j) - of_int ((2::nat) ^ (j - i))\<rfloor> = \<lfloor>x * (2 * 2 ^ j)\<rfloor> - ((2::nat) ^ (j - i))"
    using floor_diff_of_int by blast
  moreover have "(2::int) ^ (j - i) mod 2 = 0"
    by (simp add: assms)
(*
  moreover have "x * (2 * 2 ^ j) - 2 ^ j / 2 ^ i = 2^j * (2*x - 1/(2^i))"
    by (simp add: linordered_field_class.sign_simps(38))
*)
  ultimately show ?thesis
  apply (simp add: nth_cont_def)
  apply (cases "\<lfloor>x * (2 * 2 ^ i)\<rfloor>" rule: parity_cases)
  apply (simp_all)
    apply (metis minus_int_code(1) mod_diff_right_eq)
  done
qed

(*
lemma nth_cont_indep2:
  assumes "i > j"
  shows "nth_cont (x - nth_cont x i) j = nth_cont x j"
proof -
  have "(x - (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1))) * (2 ^ (j+1)) =
        (x * 2 ^ (j+1)) - ((\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1)) * (2 ^ (j+1)))"
    using left_diff_distrib by blast

  moreover have "x * (2 * 2 ^ j) - 2 ^ j / 2 ^ i = 2^j * (2*x - 1/(2^i))"
    by (simp add: linordered_field_class.sign_simps(38))

  moreover have "i > 0"
    using assms by linarith

  ultimately show ?thesis
    apply (simp add: nth_cont_def)
    apply (cases "\<lfloor>x * (2 * 2 ^ i)\<rfloor>" rule: parity_cases)
    apply (simp_all)
  sorry
qed

lemma nth_cont_indep:
  assumes "i \<noteq> j"
  shows "nth_cont (x - nth_cont x i) j = nth_cont x j"
  using assms nat_neq_iff nth_cont_indep1 nth_cont_indep2 by auto

lemma sum_nth_cont_removed:
  assumes "finite A" "n \<in> A"
  shows "sum (nth_cont (x - nth_cont x n)) A = sum (nth_cont x) (A - {n})"
proof -
  from assms have A: "A = insert n (A - {n})" by auto
  moreover hence "sum (nth_cont (x - nth_cont x n)) (insert n (A - {n})) = sum (nth_cont x) (A - {n})"
    apply (subst sum.insert)
    apply (auto simp add: assms nth_cont_removed)
    apply (rule sum.cong)
    apply (auto simp add: nth_cont_indep)
  done
  ultimately show ?thesis
    by simp
qed
*)

lemma nth_cont_shift: "nth_cont (2*x) n = (nth_cont x (n+1) * 2)"
  by (simp add: nth_cont_def mult.left_commute)

lemma modulus_2_via_shift_lemma:
  fixes x :: real
  assumes "0 \<le> x" "x < 1"
  shows "(\<Sum> i < n. \<lfloor>x * 2^(i+1)\<rfloor> mod 2 * 2^(n-i)) = \<lfloor>x * 2^(n+1)\<rfloor> - \<lfloor>x * 2^(n+1)\<rfloor> mod 2"
proof (induct n)
  case 0 with assms(1,2) show ?case
    using mod_pos_pos_trivial by auto
next
  case (Suc n) note hyp = this
  have "(\<Sum>i<n. \<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2 * 2 ^ (Suc n - i)) = (\<Sum>i<n. \<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2 * 2 ^ (n - i))*2"
    by (auto intro: sum.cong simp add: Suc_diff_le sum_distrib_right)
  \<comment> \<open> This can be proven with reference to integer division and modulus \<close>
  moreover have "\<lfloor>x * (2 ^ (n+1))\<rfloor> * 2 = \<lfloor>x * (2 ^ (n+2))\<rfloor> - \<lfloor>x * (2 ^ (n+2))\<rfloor> mod 2"
  proof -
    have "\<lfloor>x * 2^(n+1)\<rfloor> = \<lfloor>x * 2^(n+2)\<rfloor> div 2"
    proof -
      \<comment> \<open> This result should maybe be extracted? It says how an integer division can
           be expressed in binary more or less... \<close>
      have "\<lfloor>x * 2^(n+2)\<rfloor> div 2 = \<lfloor>(x * 2^(n+2)) / 2\<rfloor>"
        by linarith
      thus ?thesis
        by (simp, subst mult.assoc[THEN sym], subst mult.commute, simp add: mult.assoc)
    qed
    hence "(\<lfloor>x * 2^(n+1)\<rfloor> * 2) + \<lfloor>x * (2 ^ (n+2))\<rfloor> mod 2 = \<lfloor>x * (2 ^ (n+2))\<rfloor>"
      by simp
    hence "\<lfloor>x * (2 ^ (n+1))\<rfloor> * 2 = \<lfloor>x * (2 ^ (n+2))\<rfloor> - \<lfloor>x * (2 ^ (n+2))\<rfloor> mod 2"
      by simp
    thus ?thesis
      by (simp)
  qed
  ultimately show ?case
    using hyp by simp
qed

text \<open> This theorem shows that the nth digit of a real number x in [0..1) can equivalently
        be obtained either by shift;floor;modulus 2, or alternatively by subtracting the
        approximation of the real number up to the nth digit, followed by a shift and floor.
        It can be used to show that the recursive algorithm and functional specification
        co-incide. \<close>

theorem modulus_2_via_shift:
  fixes x :: real
  assumes "0 \<le> x" "x < 1"
  shows "\<lfloor>(x - (\<Sum>i<n. nth_cont x i))*2^(n+1)\<rfloor> = \<lfloor>x * 2^(n+1)\<rfloor> mod 2"
proof -
  have "\<lfloor>(x - (\<Sum>i<n. nth_cont x i))*2^(n+1)\<rfloor> = \<lfloor>(x*2^(n+1) - (\<Sum>i<n. nth_cont x i)*2^(n+1))\<rfloor>"
    by (simp add: left_diff_distrib)
  moreover have "(\<Sum>i<n. nth_cont x i)*2^(n+1) = of_int (\<Sum>i<n. (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) * (2 ^ (n-i)))"
  proof -
    have "(\<Sum>i<n. nth_cont x i)*2^(n+1) = (\<Sum>i<n. (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1))) * (2 ^ (n+1))"
      by (simp add: nth_cont_def)
    also have "... = (\<Sum>i<n. (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) / (2 ^ (i+1)) * (2 ^ (n+1)))"
      by (rule sum_distrib_right)
    also have "... = (\<Sum>i<n. (of_int ((\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) * (2 ^ (n-i)))))"
      by (rule sum.cong, auto simp add: power_diff)
         (metis (no_types, opaque_lifting) le_less of_int_numeral of_int_power power_diff times_divide_eq_right zero_neq_numeral)
    finally show ?thesis
      by auto
  qed
  ultimately have "\<lfloor>(x - (\<Sum>i<n. nth_cont x i))*2^(n+1)\<rfloor> =
                   \<lfloor>x * 2^(n+1)\<rfloor> - (\<Sum>i<n. (\<lfloor>x * (2 ^ (i+1))\<rfloor> mod 2) * (2 ^ (n-i)))"
    by linarith
  also from assms have "... = \<lfloor>x * 2 ^ (n + 1)\<rfloor> - (\<lfloor>x * 2 ^ (n + 1)\<rfloor> - \<lfloor>x * 2 ^ (n + 1)\<rfloor> mod 2)"
    by (subst modulus_2_via_shift_lemma, simp_all)
  finally show ?thesis
    by linarith
qed

lemma binlist_as_nth_cont:
  fixes x :: real
  assumes "0 \<le> x" "x < 1"
  shows "binlist (real_bits x n) = (\<Sum>i<n+1. nth_cont x i)"
proof (induct n)
  case 0 with assms show ?case
  proof -
    from assms have "\<lfloor>x * 2\<rfloor> = 0 \<or> \<lfloor>x * 2\<rfloor> = 1"
      by linarith
    thus ?thesis
      by (auto simp add: binlist_def nth_cont_def)
  qed
next
  case (Suc n) note hyp = this
  thus ?case
    using modulus_2_via_shift[of x "Suc n"] assms
      by (simp add: rbit_def nth_cont_def)
       (metis not_mod_2_eq_0_eq_1 of_int_0 of_int_1)
qed

lemma real_bits_rbseq:
  assumes "0 \<le> x" "x < 1" "n \<ge> i"
  shows "real_bits x n ! i = rbseq x i"
using assms proof (induct n arbitrary: i)
  case 0 with assms show ?case
    by (simp add: rbseq_def mod_pos_pos_trivial)
next
  case (Suc n')
  thus ?case
    using modulus_2_via_shift[of x "Suc n'"] assms
    by (auto simp add: nth_append rbit_def binlist_as_nth_cont rbseq_def)
qed

lemma real_bin_eq_rbseq:
  "\<lbrakk> 0 \<le> x; x < 1 \<rbrakk> \<Longrightarrow> real_bin x = rbseq x"
  by (auto simp add: real_bin_def real_bits_rbseq)

lemma of_int_floor: "\<lbrakk> 0 \<le> x; x < 1; of_int \<lfloor>x\<rfloor> = 0 \<rbrakk> \<Longrightarrow> \<lfloor>x\<rfloor> = 0"
  by (simp add: floor_unique)

lemma binlist_approaching_range:
  assumes "0 \<le> x" "x < 1"
  shows "x - binlist (real_bits x n) \<in> {0..<1/2^(n+1)}"
proof (induct n)
  case 0
  from assms have "0 \<le> x - binlist (real_bits x 0)"
  proof -
    from assms have "\<lfloor>x * 2\<rfloor> \<in> {0,1}"
      by (auto, linarith)
    with assms show ?thesis
      by (auto simp add: binlist_def, linarith)
  qed
  moreover from assms have "x - binlist (real_bits x 0) < 1/2^(0+1)"
    apply (simp add: binlist_def)
    apply (case_tac "of_int \<lfloor>x * 2\<rfloor> :: bit")
    apply (auto)
    apply (metis bit.distinct(1) floor_less_iff linorder_neqE_linordered_idom mult.left_neutral not_le of_int_1 one_less_floor mult_le_cancel_iff1 zero_less_numeral)
  done
  ultimately show ?case
    by auto
next
  case (Suc n) note hyp = this
  from hyp have blran: "(x - binlist (real_bits x n)) * (4 * 2 ^ n) \<in> {0..<2}"
    by (auto simp add: mult.commute mult.left_commute pos_less_divide_eq)
  show ?case
  proof (cases "rbit x n (real_bits x n)")
    case zero
    with hyp blran have "(x - binlist (real_bits x n)) * (4 * 2 ^ n) < 1"
      apply (auto simp add: rbit_def pos_less_divide_eq)
      apply (subgoal_tac "\<lfloor>(x - binlist (real_bits x n)) * (4 * 2 ^ n)\<rfloor> = 0")
      apply linarith
      apply (metis atLeastLessThan_iff bit.distinct(1) blran floor_less_one linorder_neqE_linordered_idom linorder_not_less of_int_1 of_int_floor one_less_floor)
    done
    with hyp zero show ?thesis
      by (auto simp add: mult_imp_less_div_pos)
  next
    case one
    with hyp blran have "(x - binlist (real_bits x n)) * (4 * 2 ^ n) \<ge> 1"
      by (auto simp add: rbit_def, metis atLeastLessThan_iff blran floor_less_iff linorder_neqE_linordered_idom not_le of_int_0 zero_less_floor zero_neq_one)
    with hyp one show ?thesis
      apply (auto)
      apply (subst add.commute)
      apply (simp add: le_diff_eq[THEN sym] pos_divide_le_eq)
    done
  qed
qed

lemma sum_binlist: "sum (binseq (real_bin x)) {..n} = binlist (real_bits x n)"
  apply (unfold binlist_def binseq_def real_bits_length real_bin_def)
  apply (rule sum.cong)
  apply (auto)
  apply (metis le_add_diff_inverse less_Suc_eq_le order_refl real_bits_plus)
  apply (metis diff_Suc_1 less_imp_Suc_add less_or_eq_imp_le real_bits_plus)
done

lemma sum_binseq_diff:
  "\<lbrakk> 0 \<le> x; x < 1 \<rbrakk> \<Longrightarrow> x - sum (binseq (real_bin x)) {..n} < 1/2^n"
  using binlist_approaching_range[of x n] sum_binlist by fastforce

lemma sum_binseq_approx: "\<lbrakk> 0 \<le> x; x < 1 \<rbrakk> \<Longrightarrow> sum (binseq (real_bin x)) {..n} \<le> x"
  using binlist_approaching_range[of x n] by (simp add: sum_binlist)

lemma sum_binseq_approx2:
  assumes "0 \<le> x" "x < 1"
  shows "sum (binseq (real_bin x)) {..<n} \<le> x"
proof (cases n)
  case 0 with assms show ?thesis by auto
next
  case (Suc n')
  with sum_binseq_approx[of x n'] assms
  show ?thesis
    by (simp add: lessThan_Suc_atMost)
qed

lemma binseq_approaches_real_bin:
  assumes "0 \<le> x" "x < 1"
  shows "(\<lambda> n. \<Sum> i<n. binseq (real_bin x) i) \<longlonglongrightarrow> x"
proof (rule LIMSEQ_I, simp)
  fix r :: real
  assume "0 < r"
  then obtain k where "1/2^k < r"
    using real_bin_lower_bound[of r] by blast
  moreover have "x - sum (binseq (real_bin x)) {..k} < 1/2^k"
    by (simp add: assms(1) assms(2) sum_binseq_diff)
  moreover have "\<And> m. m \<ge> k+1 \<Longrightarrow> sum (binseq (real_bin x)) {..<m} \<ge> sum (binseq (real_bin x)) {..k}"
    by (auto intro: sum_mono2 simp add: binseq_pos)
  ultimately have "\<And> m. m \<ge> k+1 \<Longrightarrow> x - sum (binseq (real_bin x)) {..<m} < r"
    by fastforce
  thus "\<exists>no. \<forall>n\<ge>no. \<bar>sum (binseq (real_bin x)) {..<n} - x\<bar> < r"
    by (rule_tac x="k+1" in exI, auto simp add: assms sum_binseq_approx2)
qed

lemma real_bin_inverse:
  assumes "0 \<le> x" "x < 1"
  shows "bin_real (real_bin x) = x"
  using assms
  apply (simp add: bin_real_def)
  apply (rule sym)
  apply (rule sums_unique)
  apply (simp add: sums_def binseq_approaches_real_bin)
done

lemma real_bin_inj:
  "inj_on real_bin {0..<1}"
  by (metis atLeastLessThan_iff inj_onI real_bin_inverse)

lemma sum_shift_plus_k:
  fixes f :: "nat \<Rightarrow> real"
  shows "(\<Sum> i<n. f (i + k)) = (sum f {k..<n+k})"
proof -
  have "(\<Sum> i<n. f (i + k)) = sum (\<lambda> i . f (i + k)) {0..<n}"
    by (simp add: atLeast0LessThan)
  thus ?thesis
    by (simp, subst sum.shift_bounds_nat_ivl[THEN sym], auto)
qed

lemma binseq_upper: "(\<Sum> i. binseq x (i+k)) \<le> 1/2^k"
proof (rule suminf_le_const)
  show "summable (\<lambda>i. binseq x (i + k))"
    by (simp add: summable_iff_shift binseq_summable)
next
  fix n
  have "(\<Sum>i<n. binseq x (i + k)) \<le> (\<Sum>i<n. 1 / 2 ^ (i + (k + 1)))"
  proof (rule sum_mono, unfold binseq_def)
    fix i
    assume "i \<in> {..<n}"
    thus "(of_bit (x (i + k)) / 2 ^ (i + k + 1) :: real) \<le> 1 / 2 ^ (i + (k + 1))"
      by (cases "x (i + k)", auto)
  qed
  also have "... \<le> 1/2^k"
  proof -
    have "(\<Sum>i<n. 1 / (2 :: real) ^ (i + (k + 1))) = ((\<Sum>i<n+k+1. (1 / 2) ^ i) - (\<Sum>i<k+1. (1 / 2) ^ i))"
      apply (subst sum_diff[THEN sym])
      apply (simp)
      apply (simp)
      apply (subst sum_shift_plus_k)
      apply (simp add: power_one_over)
    done
    also have "... = 1 / 2 ^ k - 1 / 2 ^ (n + k)"
      apply (subst geometric_sum)
      apply (simp)
      apply (subst geometric_sum)
      apply (simp)
      apply (simp add: power_one_over)
    done
    finally show ?thesis
      by (simp)
  qed
  finally show "(\<Sum>i<n. binseq x (i + k)) \<le> 1 / 2 ^ k" .
qed

lemma binseq_lower: "(\<Sum> i. binseq x (i+k)) \<ge> 0"
  apply (rule suminf_nonneg)
  apply (auto simp add: summable_iff_shift binseq_summable)
  apply (simp add: binseq_def)
done

lemma nonterminal_binseq_nonzero:
  assumes "nonterminal x"
  shows "(\<Sum> i. binseq x (i + k)) > 0"
proof -
  from assms obtain i where i:"x (i + k) = 1"
    by (auto simp add: terminal_def terminates_at_def, metis add.commute le_iff_add)
  thus ?thesis
  proof (rule_tac suminf_pos2[of _ i])
    show "summable (\<lambda>i. binseq x (i + k))"
      by (simp add: summable_iff_shift binseq_summable)
    show "\<And>n. 0 \<le> binseq x (n + k)"
      by (simp add: binseq_pos)
    from i show "0 < binseq x (i + k)"
      by (simp add: binseq_def)
  qed
qed

lemma list_neq_distinguish:
  assumes "xs \<noteq> ys" "length xs = length ys"
  shows "\<exists> k<length xs. (\<forall> i < k. xs!i = ys!i) \<and> xs!k \<noteq> ys!k"
using assms proof (induct xs arbitrary: ys)
  case Nil thus ?case by auto
next
  case (Cons x xs')
  note hyps = this
  then obtain y ys' where ys: "ys = y # ys'"
    by (metis length_0_conv neq_Nil_conv)
  thus ?case
  proof (cases "x = y")
    case False with hyps ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case True
    with hyps ys have "xs' \<noteq> ys'"
      by (auto)
    moreover from hyps ys have "length xs' = length ys'"
      by (auto)
      thm hyps
    ultimately obtain k where "k<length xs'" "\<forall>i<k. xs' ! i = ys' ! i" "xs' ! k \<noteq> ys' ! k"
      using hyps by auto
    thus ?thesis
      using True ys less_Suc_eq_0_disj by (rule_tac x="Suc k" in exI, auto)
  qed
qed

lemma seq_neq_distinguish:
  fixes f :: "nat \<Rightarrow> 'b"
  assumes "f \<noteq> g"
  shows "\<exists> k. (\<forall> i < k. f(i) = g(i)) \<and> f(k) \<noteq> g(k)"
proof -
  from assms obtain k' where k': "f(k') \<noteq> g(k')"
    by auto
  let ?xs = "map f [0..<k'+1]"
  let ?ys = "map g [0..<k'+1]"
  from k' obtain k where k: "k < k'+1" "(\<forall> i < k. ?xs!i = ?ys!i)" "?xs!k \<noteq> ?ys!k"
    using list_neq_distinguish[of "?xs" "?ys"] by auto
  have "(\<forall>i<k. f i = g i)"
    by (auto, metis (no_types, lifting) add.left_neutral add_lessD1 diff_zero k(1) k(2) less_imp_add_positive nth_map_upt)
  moreover from k(3) have "f k \<noteq> g k"
    by (metis add.left_neutral diff_zero k(1) k(3) nth_map_upt)
  ultimately show ?thesis
    by (auto)
qed

lemma bin_real_nonterminal_inj_aux:
  assumes "nonterminal x" "nonterminal y" "x \<noteq> y"
  shows "bin_real x \<noteq> bin_real y"
proof -
  from assms(3) obtain k where k: "\<forall> i < k. x(i) = y(i)" "x(k) \<noteq> y(k)"
    using seq_neq_distinguish by blast
  have "bin_real x =
         (\<Sum>i<k. binseq x i) + of_bit (x k) / 2 ^(k+1) + (\<Sum>i. binseq x (i+(k+1)))"
    by (simp add: bin_real_def suminf_split_initial_segment[of _ "k+1"] binseq_summable)
       (simp add: binseq_def)
  moreover
  have "bin_real y =
         (\<Sum>i<k. binseq y i) + of_bit (y k) / 2 ^(k+1) + (\<Sum>i. binseq y (i+(k+1)))"
    by (simp add: bin_real_def suminf_split_initial_segment[of _ "k+1"] binseq_summable)
       (simp add: binseq_def)
  moreover
  from k(1) have "(\<Sum>i<k. binseq x i) = (\<Sum>i<k. binseq y i)"
    by (auto simp add: binseq_def)
  moreover
  have "of_bit (x k) / 2 ^(k+1) + (\<Sum>i. binseq x (i+(k+1))) \<noteq>
        of_bit (y k) / 2 ^(k+1) + (\<Sum>i. binseq y (i+(k+1)))"
  proof (cases "x k")
    case one
    moreover then have y:"y k = 0"
      using k(2) by auto
    moreover have "(\<Sum>i. binseq y (i + (k + 1))) \<le> 1/2^(k+1)"
      by (rule binseq_upper)
    moreover from assms(1) have "(\<Sum>i. binseq x (i + (k + 1))) > 0"
      by (rule nonterminal_binseq_nonzero)
    ultimately have "1 / 2^(k+1) + (\<Sum>i. binseq x (i+(k+1))) > (\<Sum>i. binseq y (i+(k+1)))"
      by simp
    with one y show ?thesis
      by simp
  next
    case zero
    moreover then have y:"y k = 1"
      using k(2) by auto
    moreover have "(\<Sum>i. binseq x (i + (k + 1))) \<le> 1/2^(k+1)"
      by (rule binseq_upper)
    moreover from assms(2) have "(\<Sum>i. binseq y (i + (k + 1))) > 0"
      by (rule nonterminal_binseq_nonzero)
    ultimately have "1 / 2^(k+1) + (\<Sum>i. binseq y (i+(k+1))) > (\<Sum>i. binseq x (i+(k+1)))"
      by simp
    with zero y show ?thesis
      by simp
  qed

  ultimately show ?thesis
    by auto
qed

text \<open> There is an injection from non-terminal infinite bit sequences to the real numbers \<close>

lemma bin_real_inj: "inj_on bin_real NonTermBitSeqs"
  using bin_real_nonterminal_inj_aux by (blast intro: inj_onI)

lemma bin_real_terminal_def:
  assumes "terminal x"
  obtains k where "bin_real x = (\<Sum>i<k. binseq x i)"
proof -
  from assms obtain k where "\<forall>i\<ge>k. x i = 0"
    by (auto simp add: terminal_def terminates_at_def)
  hence "bin_real x = (\<Sum>i<k. binseq x i)"
    unfolding bin_real_def
    by (subst suminf_finite[of "{..<k}"], auto simp add: binseq_def)
  thus ?thesis
    using that by blast
qed

lemma sum_int: "\<lbrakk> finite A; \<forall> i. f i \<in> \<int> \<rbrakk> \<Longrightarrow> sum f A \<in> \<int>"
  by (induct rule: finite_induct, simp_all)

lemma bin_real_terminal_dyadic:
  assumes "terminal x"
  shows "dyadic (bin_real x)"
proof -
  from assms obtain k where "bin_real x = (\<Sum>i<k. binseq x i)"
    using bin_real_terminal_def by blast
  also have "... = (\<Sum>i<k. (binseq x i * 2^k)) / 2^k"
    by (simp add: sum_divide_distrib)
  also have "... = (\<Sum>i<k. of_bit (x i) * 2 ^ (k - (i+1))) / 2 ^ k"
  proof -
    have "\<And>i. i \<in> {..<k} \<Longrightarrow> (of_bit (x i) :: real) / 2^(i+1) * 2^k = of_bit (x i) * 2^(k-(i+1))"
      by (simp add: power_diff)
    hence "(\<Sum>i<k. (binseq x i * 2^k)) = (\<Sum>i<k. of_bit (x i) * 2 ^ (k - (i+1)))"
      by (auto intro: sum.cong simp add: binseq_def)
    thus ?thesis by simp
  qed
  finally show ?thesis
  proof (simp)
    have "(\<Sum>i<k. of_bit (x i) * 2 ^ (k - (i + 1))) \<in> \<int>"
      by (auto intro!: sum_int)
    thus "dyadic ((\<Sum>i\<in>{..<k} \<inter> {i. x i = 1}. 2 ^ (k - Suc i)) / 2 ^ k)"
      by (auto simp add: dyadic_def)
  qed
qed

lemma terminal_rbseq_drat:
  "x \<in> {0<..<1} \<Longrightarrow> terminal (rbseq (of_drat x))"
proof (erule drat_0_1_induct, simp add: rbseq_def terminal_def terminates_at_def)
  fix a :: int and b :: nat
  assume coprime: "even a \<longrightarrow> b = 0"
  have "\<And> j. j \<ge> b \<Longrightarrow> of_int (\<lfloor>real_of_int a * (2 * 2 ^ j) / 2 ^ b\<rfloor> mod 2) = 0"
  proof -
    fix j
    assume "j \<ge> b"
    then have "real_of_int a * (2 * 2 ^ j) / 2 ^ b = real_of_int a * (2 * 2 ^ (j-b))"
      by (simp add: power_diff)
    moreover have "real_of_int a * (2 * 2 ^ (j-b)) \<in> \<int>"
      by simp
    moreover hence "\<lfloor>real_of_int a * (2 * 2 ^ (j-b))\<rfloor> mod 2 = (2 * \<lfloor>real_of_int a * 2 ^ (j - b)\<rfloor>) mod 2"
      by (metis (no_types, opaque_lifting) floor_of_int mult.left_commute of_int_mult of_int_numeral of_int_power)
    ultimately show "of_int (\<lfloor>real_of_int a * (2 * 2 ^ j) / 2 ^ b\<rfloor> mod 2) = 0"
      by simp
  qed
  with coprime show " \<exists>i. \<forall>j\<ge>i. of_int (\<lfloor>of_drat (DFract a b) * ((2::real) * 2 ^ j)\<rfloor> mod 2) = 0"
    by (rule_tac x="b" in exI, auto simp add:of_drat_DFract)
qed

lemma real_bin_dyadic_terminal:
  assumes "0 \<le> x" "x < 1" "x \<in> \<rat>\<^sub>D"
  shows "terminal (real_bin x)"
proof (cases "x = 0")
  case True thus ?thesis
    by (simp add: real_bin_eq_rbseq terminal_def terminates_at_def rbseq_def)
next
  case False
  from assms obtain n where n:"x = of_drat n"
     by (erule_tac drat_cases, auto)
  with assms False have nr: "n \<in> {0<..<1}"
    using of_drat_0_1 by force
  show ?thesis
    apply (subst real_bin_eq_rbseq)
    apply (simp_all add: assms)
    apply (simp add: n nr)
    apply (subst terminal_rbseq_drat)
    apply (simp_all only: nr)
  done
qed

lemma bin_real_terminates_binlist:
  assumes "terminates_at x k"
  shows "bin_real x = binlist (map x [0..<k])"
proof -
  from assms have "(\<Sum>n. binseq x (n + k)) = 0"
    by (simp add: suminf_eq_zero_iff binseq_summable summable_iff_shift binseq_def terminates_at_def)
  thus ?thesis
    apply (simp add: bin_real_def binlist_def)
    apply (subst suminf_split_initial_segment[of _ k])
    apply (simp add: binseq_summable)
    apply (simp add: binseq_def)
  done
qed

definition termseq_list :: "(nat \<Rightarrow> ('a::zero)) \<Rightarrow> 'a list" where
"termseq_list x = map x [0..<LEAST k. terminates_at x k]"

definition list_termseq :: "'a list \<Rightarrow> (nat \<Rightarrow> ('a::zero))" where
"list_termseq xs = (\<lambda> i. if (i < length xs) then xs!i else 0)"

definition "TermLists = {xs. xs = [] \<or> (xs \<noteq> [] \<and> last xs \<noteq> 0)}"

lemma TermLists_terminates_at:
  "xs \<in> TermLists \<Longrightarrow> terminates_at (list_termseq xs) k \<longleftrightarrow> k \<ge> length xs"
  apply (auto simp add: list_termseq_def terminates_at_def)
  apply (auto simp add: TermLists_def)
  using last_conv_nth not_less_eq_eq apply force
done

lemma terminal_list_termseq: "terminal (list_termseq xs)"
  apply (auto simp add: list_termseq_def terminal_def terminates_at_def)
  using not_le apply blast
done

lemma Least_terminates_at_list: "xs \<in> TermLists \<Longrightarrow> (LEAST k. terminates_at (list_termseq xs) k) = length xs"
  by (auto simp add: TermLists_terminates_at simp add: Least_equality)

lemma list_termseq_inverse:
  assumes "xs \<in> TermLists"
  shows "termseq_list (list_termseq xs) = xs"
proof -
  have "xs = map (\<lambda> i. xs ! i) [0..<length xs]"
    by (simp add: map_nth)
  also have "... = map (list_termseq xs) [0..<LEAST k. terminates_at (list_termseq xs) k]"
  proof -
    have "\<And>x. x < length xs \<Longrightarrow> xs ! x = list_termseq xs x"
      by (simp add: list_termseq_def)
    thus ?thesis
      by (auto simp add: Least_terminates_at_list assms)
  qed
  finally show ?thesis
    by (auto simp add: TermLists_def list_termseq_def termseq_list_def terminates_at_def)
qed

lemma termseq_list_inverse:
  assumes "x \<in> TermSeqs"
  shows "list_termseq (termseq_list x) = x"
  apply (rule ext)
  apply (auto simp add: list_termseq_def termseq_list_def)
  apply (metis (mono_tags, lifting) LeastI_ex assms le_less_linear mem_Collect_eq terminal_def terminates_at_def)
done

lemma termseq_list_inj:
  "inj_on termseq_list TermSeqs"
  by (metis inj_onI termseq_list_inverse)

lemma lenth_termseq_list:
  "length (termseq_list x) = (LEAST k. terminates_at x k)"
  by (simp add: termseq_list_def)

lemma terminal_TermLists:
  assumes "terminal x"
  shows "termseq_list x \<in> TermLists"
proof -
  let ?kx = "LEAST k. terminates_at x k"
  have tx: "terminates_at x ?kx"
    by (metis LeastI assms terminal_def)
  moreover have mt: "\<And> k. terminates_at x k \<Longrightarrow> ?kx \<le> k"
    by (auto intro: wellorder_Least_lemma)
  ultimately show ?thesis
  proof (auto simp add: TermLists_def)
    assume as: "termseq_list x \<noteq> []" "last (termseq_list x) = 0"
    hence kx_nz: "?kx > 0"
      by (metis length_greater_0_conv lenth_termseq_list)
    hence "x (?kx - 1) \<noteq> 0"
    proof -
      from kx_nz mt have nt_kxs: "\<not> terminates_at x (?kx - 1)"
        by (metis One_nat_def Suc_n_not_le_n diff_Suc_1 gr0_implies_Suc)
      show ?thesis
      proof
        assume "x (?kx - 1) = 0"
        moreover from tx have "\<forall>j\<ge>?kx. x j = 0"
          by (simp only: terminates_at_def)
        ultimately have "\<forall>j\<ge>?kx-1. x j = 0"
          by (auto, metis Suc_diff_Suc diff_zero kx_nz le_antisym not_less_eq_eq)
        hence "terminates_at x (?kx - 1)"
          by (simp only: terminates_at_def)
        with nt_kxs show False by simp
      qed
    qed

    with as show False
      by (simp add: termseq_list_def last_map)
  qed
qed

lemma termseq_list_surj:
  "termseq_list ` TermSeqs = TermLists"
  apply (auto simp add: terminal_TermLists)
  apply (auto simp add: image_Collect)
  apply (rule_tac x="list_termseq x" in exI)
  apply (simp add: list_termseq_inverse terminal_list_termseq)
done

lemma termseq_list_bij:
  "bij_betw termseq_list TermSeqs TermLists"
  by (simp add: bij_betw_def termseq_list_inj termseq_list_surj)

thm infinite_iff_countable_subset

lemma infinite_TermBitLists:
  "infinite (TermLists :: bit list set)"
proof -
  let ?f = "(\<lambda> i. replicate i 1) :: nat \<Rightarrow> bit list"
  have "inj ?f"
    by (meson injI replicate_eq_replicate)
  moreover have "range ?f \<subseteq> TermLists"
    by (auto simp add: TermLists_def)
  ultimately show ?thesis
    by (auto simp add: infinite_iff_countable_subset)
qed

instance bit :: countable
  apply (intro_classes)
  apply (rule_tac x="of_bit" in exI)
  apply (rule injI)
  apply (rename_tac x y)
  apply (case_tac x; case_tac y)
  apply (simp_all)
done

lemma countable_TermBitLists:
  "countable (TermLists :: bit list set)"
  by (fact countableI_type)

lemma card_of_TermBitLists:
  "|TermLists :: bit list set| =o |UNIV :: nat set|"
  apply (subst card_of_ordIso[THEN sym])
  using countable_TermBitLists infinite_TermBitLists to_nat_on_infinite apply blast
done

lemma card_of_TermBitSeqs:
  "|TermBitSeqs| =o |TermLists :: bit list set|"
  apply (subst card_of_ordIso[THEN sym])
using termseq_list_bij by blast

lemma card_less_TermBitSeqs_BitSeqs: "|TermBitSeqs| <o |BitSeqs|"
proof -
  have "|TermBitSeqs| =o |UNIV :: nat set|"
    using card_of_TermBitLists card_of_TermBitSeqs ordIso_transitive by blast
  moreover have "|UNIV :: nat set set| =o |BitSeqs|"
    by (simp add: card_of_bit_seq ordIso_symmetric)
  moreover have "|UNIV :: nat set| <o |UNIV :: nat set set|"
    using card_of_set_type by blast
  ultimately show ?thesis
    apply (rule_tac ordLess_ordIso_trans)
    apply (rule_tac ordIso_ordLess_trans)
    apply (assumption)
    apply (rule card_of_set_type)
    apply auto
  done
qed

lemma infinite_BitSeqs:
  "infinite BitSeqs"
  using bij_betw_finite bij_bits_to_nats infinite_UNIV by blast

lemma card_eq_NonTermBitSeqs_BitSeqs: "|NonTermBitSeqs| =o |BitSeqs|"
proof -
  have "|BitSeqs - TermBitSeqs| =o |BitSeqs|"
    apply (rule card_of_Un_diff_infinite)
    apply (simp_all add: infinite_BitSeqs card_less_TermBitSeqs_BitSeqs)
  done
  moreover have "BitSeqs - TermBitSeqs = NonTermBitSeqs"
    by (auto)
  ultimately show ?thesis
    by (simp)
qed

lemma card_le_NonTermBitSeqs_Reals: "|NonTermBitSeqs| \<le>o |UNIV :: real set|"
  using bin_real_inj card_of_ordLeqI by auto

lemma card_le_BitSeqs_Reals: "|BitSeqs| \<le>o |UNIV :: real set|"
  using card_eq_NonTermBitSeqs_BitSeqs card_le_NonTermBitSeqs_Reals ordIso_ordLess_trans ordIso_symmetric ordIso_transitive ordLeq_iff_ordLess_or_ordIso by blast

lemma card_le_PNats_Reals: "|UNIV :: nat set set| \<le>o |UNIV :: real set|"
  using card_le_BitSeqs_Reals card_of_bit_seq ordIso_iff_ordLeq ordLeq_transitive by blast

definition dcut :: "real \<Rightarrow> rat set" where
"dcut r = {q. real_of_rat q < r}"

lemma dedekind_cut_lemma:
  assumes "r1 < r2"
  shows "dcut r1 \<noteq> dcut r2"
proof -
  from assms obtain q :: rat where "r1 < of_rat q" and "of_rat q < r2"
    using of_rat_dense by auto
  hence "q \<notin> dcut r1" "q \<in> dcut r2"
    by (auto simp add: dcut_def)
  thus ?thesis
    by auto
qed

lemma dedekind_cut_inj:
  "inj dcut"
  by (simp add: dedekind_cut_lemma linorder_injI)

lemma real_nat_set: "\<exists> f :: real \<Rightarrow> nat set. inj f"
  apply (rule_tac x="\<lambda> n. to_nat ` dcut n" in exI)
  apply (simp add: dedekind_cut_lemma inj_image_eq_iff linorder_injI)
done

lemma card_le_Reals_PNats: "|UNIV :: real set| \<le>o |UNIV :: nat set set|"
proof -
  obtain f :: "real \<Rightarrow> nat set" where "inj f"
    using real_nat_set by blast
  thus ?thesis
    by (rule card_of_ordLeqI, auto)
qed

lemma card_eq_Reals_PNats: "|UNIV :: real set| =o |UNIV :: nat set set|"
  by (simp add: card_le_PNats_Reals card_le_Reals_PNats ordIso_iff_ordLeq)

definition real_nats_bij :: "real \<Rightarrow> nat set" where
"real_nats_bij = (SOME f. bij f)"

lemma real_nats_bij: "bij real_nats_bij"
proof -
  obtain f :: "real \<Rightarrow> nat set" where "bij f"
    using card_of_ordIso[of "UNIV :: real set" "UNIV :: nat set set"] card_eq_Reals_PNats
    by (auto)
  thus ?thesis
    by (simp add: real_nats_bij_def, metis someI_ex)
qed

lemma "|BitSeqs| =o |UNIV :: bit set| ^c |UNIV :: nat set|"
  by (simp add: card_of_Func_UNIV_UNIV cexp_def ordIso_symmetric)

declare [[linarith_split_limit=10]]

end


(*
  File:     Finite_Fourier_Series.thy
  Authors:  Rodrigo Raya, EPFL; Manuel Eberl, TUM

  Existence and uniqueness of finite Fourier series for periodic arithmetic functions
*)
section \<open>Finite Fourier series\<close>
theory Finite_Fourier_Series
imports
  Polynomial_Interpolation.Lagrange_Interpolation
  Complex_Roots_Of_Unity
begin

subsection \<open>Auxiliary facts\<close>

lemma lagrange_exists:
  assumes d: "distinct (map fst zs_ws)"
  defines e: "(p :: complex poly) \<equiv> lagrange_interpolation_poly zs_ws"
  shows "degree p \<le> (length zs_ws)-1"
        "(\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p x = y)"
proof -
  from e show "degree p \<le> (length zs_ws - 1)"
    using degree_lagrange_interpolation_poly by auto
  from e d have
    "poly p x = y" if "(x,y) \<in> set zs_ws" for x y
    using that lagrange_interpolation_poly by auto
  then show "(\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p x = y)"
    by auto
qed

lemma lagrange_unique:
  assumes o: "length zs_ws > 0" (* implicit in theorem *)
  assumes d: "distinct (map fst zs_ws)"
  assumes 1: "degree (p1 :: complex poly) \<le> (length zs_ws)-1 \<and>
               (\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p1 x = y)"
  assumes 2: "degree (p2 :: complex poly) \<le> (length zs_ws)-1 \<and>
               (\<forall>x y. (x,y) \<in> set zs_ws \<longrightarrow> poly p2 x = y)"
  shows "p1 = p2"
proof (cases "p1 - p2 = 0")
  case True then show ?thesis by simp
next
  case False
    have "poly (p1-p2) x = 0" if "x \<in> set (map fst zs_ws)" for x
      using 1 2 that by (auto simp add: field_simps)
    from this d have 3: "card {x. poly (p1-p2) x = 0} \<ge> length zs_ws"
    proof (induction zs_ws)
      case Nil then show ?case by simp
    next
      case (Cons z_w zs_ws)
      from  False poly_roots_finite
      have f: "finite {x. poly (p1 - p2) x = 0}" by blast
      from Cons have "set (map fst (z_w # zs_ws)) \<subseteq> {x. poly (p1 - p2) x = 0}"
        by auto
      then have i: "card (set (map fst (z_w # zs_ws))) \<le> card {x. poly (p1 - p2) x = 0}"
        using card_mono f by blast
      have "length (z_w # zs_ws) \<le> card (set (map fst (z_w # zs_ws)))"
        using Cons.prems(2) distinct_card by fastforce
      from this i show ?case by simp
    qed
    from 1 2 have 4: "degree (p1 - p2) \<le> (length zs_ws)-1"
      using degree_diff_le by blast

    have "p1 - p2 = 0"
    proof (rule ccontr)
      assume "p1 - p2 \<noteq> 0"
      then have "card {x. poly (p1-p2) x = 0} \<le> degree (p1-p2)"
        using poly_roots_degree by blast
      then have "card {x. poly (p1-p2) x = 0} \<le> (length zs_ws)-1"
        using 4 by auto
      then show "False" using 3 o by linarith
    qed
    then show ?thesis by simp
qed

text \<open>Theorem 8.2\<close>
corollary lagrange:
  assumes "length zs_ws > 0" "distinct (map fst zs_ws)"
  shows "(\<exists>! (p :: complex poly).
              degree p \<le> length zs_ws - 1 \<and>
              (\<forall>x y. (x, y) \<in> set zs_ws \<longrightarrow> poly p x = y))"
  using assms lagrange_exists lagrange_unique by blast

lemma poly_altdef':
 assumes gr: "k \<ge> degree p"
 shows "poly p (z::complex) = (\<Sum>i\<le>k. coeff p i * z ^ i)"
proof -
  {fix z
  have 1: "poly p z = (\<Sum>i\<le>degree p. coeff p i * z ^ i)"
    using poly_altdef[of p z] by simp
  have "poly p z = (\<Sum>i\<le>k. coeff p i * z ^ i)"
    using gr
  proof (induction k)
    case 0 then show ?case by (simp add: poly_altdef)
  next
    case (Suc k)
    then show ?case
      using "1" le_degree not_less_eq_eq by fastforce
  qed}
  then show ?thesis using gr by blast
qed

subsection \<open>Definition and uniqueness\<close>

definition finite_fourier_poly :: "complex list \<Rightarrow> complex poly" where
  "finite_fourier_poly ws =
    (let k = length ws
      in  poly_of_list [1 / k * (\<Sum>m<k. ws ! m * unity_root k (-n*m)). n \<leftarrow> [0..<k]])"

lemma degree_poly_of_list_le: "degree (poly_of_list ws) \<le> length ws - 1"
  by (intro degree_le) (auto simp: nth_default_def)

lemma degree_finite_fourier_poly: "degree (finite_fourier_poly ws) \<le> length ws - 1"
  unfolding finite_fourier_poly_def
proof (subst Let_def)
  let ?unrolled_list = "
       (map (\<lambda>n. complex_of_real (1 / real (length ws)) *
                  (\<Sum>m<length ws.
                      ws ! m *
                      unity_root (length ws) (- int n * int m)))
         [0..<length ws])"
  have "degree (poly_of_list ?unrolled_list) \<le> length ?unrolled_list - 1"
    by (rule degree_poly_of_list_le)
  also have "\<dots> = length [0..<length ws] - 1"
    using length_map by auto
  also have "\<dots> = length ws - 1" by auto
  finally show "degree (poly_of_list ?unrolled_list) \<le> length ws - 1" by blast
qed

lemma coeff_finite_fourier_poly:
  assumes "n < length ws"
  defines "k \<equiv> length ws"
  shows "coeff (finite_fourier_poly ws) n =
         (1/k) * (\<Sum>m < k. ws ! m * unity_root k (-n*m))"
  using assms degree_finite_fourier_poly
  by (auto simp: Let_def nth_default_def finite_fourier_poly_def)

lemma poly_finite_fourier_poly:
  fixes m :: int and ws
  defines "k \<equiv> length ws"
  assumes "m \<in> {0..<k}"
  assumes "m < length ws"
  shows "poly (finite_fourier_poly ws) (unity_root k m) = ws ! (nat m)"
proof -
  have "k > 0" using assms by auto

  have distr: "
   (\<Sum>j<length ws. ws ! j * unity_root k (-i*j))*(unity_root k (m*i)) =
   (\<Sum>j<length ws. ws ! j * unity_root k (-i*j)*(unity_root k (m*i)))"
   for i
  using sum_distrib_right[of "\<lambda>j. ws ! j * unity_root k (-i*j)"
                            "{..<k}" "(unity_root k (m*i))"]
  using k_def by blast

  {fix j i :: nat
   have "unity_root k (-i*j)*(unity_root k (m*i)) = unity_root k (-i*j+m*i)"
     by (simp add: unity_root_diff unity_root_uminus field_simps)
   also have "\<dots> = unity_root k (i*(m-j))"
     by (simp add: algebra_simps)
   finally have "unity_root k (-i*j)*(unity_root k (m*i)) = unity_root k (i*(m-j))"
     by simp
   then have "ws ! j * unity_root k (-i*j)*(unity_root k (m*i)) =
              ws ! j * unity_root k (i*(m-j))"
     by auto
 } note prod = this

 have zeros:
   "(unity_root_sum k (m-j) \<noteq> 0 \<longleftrightarrow> m = j)
     " if "j \<ge> 0 \<and> j < k"  for j
   using k_def that assms unity_root_sum_nonzero_iff[of _ "m-j"] by simp
  then have sum_eq:
    "(\<Sum>j\<le>k-1. ws ! j * unity_root_sum k (m-j)) =
          (\<Sum>j\<in>{nat m}.  ws ! j * unity_root_sum k (m-j))"
    using assms(2) by (intro sum.mono_neutral_right,auto)

  have "poly (finite_fourier_poly ws) (unity_root k m) =
        (\<Sum>i\<le>k-1. coeff (finite_fourier_poly ws) i * (unity_root k m) ^ i)"
    using degree_finite_fourier_poly[of ws] k_def
          poly_altdef'[of "finite_fourier_poly ws" "k-1" "unity_root k m"] by blast
  also have "\<dots> = (\<Sum>i<k. coeff (finite_fourier_poly ws) i * (unity_root k m) ^ i)"
    using assms(2) by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>i<k. 1 / k *
    (\<Sum>j<k. ws ! j * unity_root k (-i*j)) * (unity_root k m) ^ i)"
    using coeff_finite_fourier_poly[of _ ws] k_def by auto
  also have "\<dots> = (\<Sum>i<k. 1 / k *
    (\<Sum>j<k. ws ! j * unity_root k (-i*j))*(unity_root k (m*i)))"
    using unity_root_pow by auto
  also have "\<dots> = (\<Sum>i<k. 1 / k *
    (\<Sum>j<k. ws ! j * unity_root k (-i*j)*(unity_root k (m*i))))"
    using distr k_def by simp
  also have "\<dots> = (\<Sum>i<k. 1 / k *
    (\<Sum>j<k. ws ! j * unity_root k (i*(m-j))))"
    using prod by presburger
  also have "\<dots> = 1 / k * (\<Sum>i<k.
    (\<Sum>j<k. ws ! j * unity_root k (i*(m-j))))"
    by (simp add: sum_distrib_left)
  also have "\<dots> = 1 / k * (\<Sum>j<k.
    (\<Sum>i<k. ws ! j * unity_root k (i*(m-j))))"
    using sum.swap by fastforce
  also have "\<dots> = 1 / k * (\<Sum>j<k. ws ! j * (\<Sum>i<k. unity_root k (i*(m-j))))"
    by (simp add: vector_space_over_itself.scale_sum_right)
  also have "\<dots> = 1 / k * (\<Sum>j<k. ws ! j * unity_root_sum k (m-j))"
    unfolding unity_root_sum_def by (simp add: algebra_simps)
  also have "(\<Sum>j<k. ws ! j * unity_root_sum k (m-j)) = (\<Sum>j\<le>k-1. ws ! j * unity_root_sum k (m-j))"
    using \<open>k > 0\<close> by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>j\<in>{nat m}.  ws ! j * unity_root_sum k (m-j))"
    using sum_eq .
  also have "\<dots> = ws ! (nat m) * k"
    using assms(2) by (auto simp: algebra_simps)
  finally have "poly (finite_fourier_poly ws) (unity_root k m) = ws ! (nat m)"
    using assms(2) by auto
  then show ?thesis by simp
qed

text \<open>Theorem 8.3\<close>
theorem finite_fourier_poly_unique:
  assumes "length ws > 0"
  defines "k \<equiv> length ws"
  assumes "(degree p \<le> k - 1)"
  assumes "(\<forall>m \<le> k-1. (ws ! m) = poly p (unity_root k m))"
  shows "p = finite_fourier_poly ws"
proof -
  let ?z = "map (\<lambda>m. unity_root k m) [0..<k]"
  have k: "k > 0" using assms by auto
  from k have d1: "distinct ?z"
    unfolding distinct_conv_nth using unity_root_eqD[OF k] by force
  let ?zs_ws = "zip ?z ws"
  from d1 k_def have d2: "distinct (map fst ?zs_ws)" by simp
  have l2: "length ?zs_ws > 0" using assms(1) k_def by auto
  have l3: "length ?zs_ws = k" by (simp add: k_def)

  from degree_finite_fourier_poly have degree: "degree (finite_fourier_poly ws) \<le> k - 1"
    using k_def by simp

  have interp: "poly (finite_fourier_poly ws) x = y"
    if "(x, y) \<in> set ?zs_ws" for x y
  proof -
    from that obtain n where "
         x = map (unity_root k \<circ> int) [0..<k] ! n \<and>
         y = ws ! n \<and>
         n < length ws"
      using in_set_zip[of "(x,y)" "(map (unity_root k) (map int [0..<k]))" ws]
      by auto
    then have "
         x = unity_root k (int n) \<and>
         y = ws ! n \<and>
         n < length ws"
      using nth_map[of n "[0..<k]" "unity_root k \<circ> int" ] k_def by simp
    thus "poly (finite_fourier_poly ws) x = y"
      by (simp add: poly_finite_fourier_poly k_def)
  qed

  have interp_p: "poly p x = y" if "(x,y) \<in> set ?zs_ws" for x y
  proof -
    from that obtain n where "
         x = map (unity_root k \<circ> int) [0..<k] ! n \<and>
         y = ws ! n \<and>
         n < length ws"
      using in_set_zip[of "(x,y)" "(map (unity_root k) (map int [0..<k]))" ws]
      by auto
    then have rw: "x = unity_root k (int n)" "y = ws ! n" "n < length ws"
      using nth_map[of n "[0..<k]" "unity_root k \<circ> int" ] k_def by simp+
    show "poly p x = y"
      unfolding rw(1,2) using assms(4) rw(3) k_def by simp
  qed

  from lagrange_unique[of _ p "finite_fourier_poly ws"] d2 l2
  have l: "
    degree p \<le> k - 1 \<and>
    (\<forall>x y. (x, y) \<in> set ?zs_ws \<longrightarrow> poly p x = y) \<Longrightarrow>
    degree (finite_fourier_poly ws) \<le> k - 1 \<and>
    (\<forall>x y. (x, y) \<in> set ?zs_ws \<longrightarrow> poly (finite_fourier_poly ws) x = y) \<Longrightarrow>
    p = (finite_fourier_poly ws)"
    using l3 by fastforce
  from assms degree interp interp_p l3
  show "p = (finite_fourier_poly ws)" using l by blast
qed

text \<open>
  The following alternative formulation returns a coefficient
\<close>
definition finite_fourier_poly' :: "(nat \<Rightarrow> complex) \<Rightarrow> nat \<Rightarrow> complex poly" where
  "finite_fourier_poly' ws k =
     (poly_of_list [1 / k * (\<Sum>m<k. (ws m) * unity_root k (-n*m)). n \<leftarrow> [0..<k]])"

lemma finite_fourier_poly'_conv_finite_fourier_poly:
  "finite_fourier_poly' ws k = finite_fourier_poly [ws n. n \<leftarrow> [0..<k]]"
  unfolding finite_fourier_poly_def finite_fourier_poly'_def by simp

lemma degree_finite_fourier_poly': "degree (finite_fourier_poly' ws k) \<le> k - 1"
  using degree_finite_fourier_poly[of "[ws n. n \<leftarrow> [0..<k]]"]
  by (auto simp: finite_fourier_poly'_conv_finite_fourier_poly)

lemma poly_finite_fourier_poly':
  fixes m :: int and k
  assumes "m \<in> {0..<k}"
  shows "poly (finite_fourier_poly' ws k) (unity_root k m) = ws (nat m)"
  using assms poly_finite_fourier_poly[of m "[ws n. n \<leftarrow> [0..<k]]"]
  by (auto simp: finite_fourier_poly'_conv_finite_fourier_poly poly_finite_fourier_poly)

lemma finite_fourier_poly'_unique:
  assumes "k > 0"
  assumes "degree p \<le> k - 1"
  assumes "\<forall>m\<le>k-1. ws m = poly p (unity_root k m)"
  shows "p = finite_fourier_poly' ws k"
proof -
  let ?ws = "[ws n. n \<leftarrow> [0..<k]]"
  from finite_fourier_poly_unique have "p = finite_fourier_poly ?ws" using assms by simp
  also have "\<dots> = finite_fourier_poly' ws k"
    using finite_fourier_poly'_conv_finite_fourier_poly ..
  finally show "p = finite_fourier_poly' ws k" by blast
qed

lemma fourier_unity_root:
  fixes k :: nat
  assumes "k > 0"
  shows "poly (finite_fourier_poly' f k) (unity_root k m) =
    (\<Sum>n<k.1/k*(\<Sum>m<k.(f m)*unity_root k (-n*m))*unity_root k (m*n))"
proof -
  have "poly (finite_fourier_poly' f k) (unity_root k m) =
        (\<Sum>n\<le>k-1. coeff (finite_fourier_poly' f k) n *(unity_root k m)^n)"
    using poly_altdef'[of "finite_fourier_poly' f k" "k-1" "unity_root k m"]
          degree_finite_fourier_poly'[of f k] by simp
  also have "\<dots> = (\<Sum>n\<le>k-1. coeff (finite_fourier_poly' f k) n *(unity_root k (m*n)))"
    using unity_root_pow by simp
  also have "\<dots> = (\<Sum>n<k. coeff (finite_fourier_poly' f k) n *(unity_root k (m*n)))"
    using assms by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>n<k.(1/k)*(\<Sum>m<k.(f m)*unity_root k (-n*m))*(unity_root k (m*n)))"
    using coeff_finite_fourier_poly'[of _ k f] by simp
  finally show
   "poly (finite_fourier_poly' f k) (unity_root k m) =
    (\<Sum>n<k.1/k*(\<Sum>m<k.(f m)*unity_root k (-n*m))*unity_root k (m*n))"
    by blast
qed

subsection \<open>Expansion of an arithmetical function\<close>

text \<open>Theorem 8.4\<close>
theorem fourier_expansion_periodic_arithmetic:
  assumes "k > 0"
  assumes "periodic_arithmetic f k"
  defines "g \<equiv> (\<lambda>n. (1 / k) * (\<Sum>m<k. f m * unity_root k (-n * m)))"
    shows "periodic_arithmetic g k"
      and "f m = (\<Sum>n<k. g n * unity_root k (m * n))"
proof -
 {fix l
  from unity_periodic_arithmetic mult_period
  have period: "periodic_arithmetic (\<lambda>x. unity_root k x) (k*l)" by simp}
  note period = this
 {fix n l
  have "unity_root k (-(n+k)*l) = cnj (unity_root k ((n+k)*l))"
    by (simp add: unity_root_uminus unity_root_diff ring_distribs unity_root_add)
  also have "unity_root k ((n+k)*l) = unity_root k (n*l)"
    by (intro unity_root_cong) (auto simp: cong_def algebra_simps)
  also have "cnj \<dots> = unity_root k (-n*l)"
    using unity_root_uminus by simp
  finally have "unity_root k (-(n+k)*l) = unity_root k (-n*l)" by simp}
  note u_period = this

  show 1: "periodic_arithmetic g k"
    unfolding periodic_arithmetic_def
  proof
    fix n

    have "g(n+k) = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-(n+k)*m))"
      using assms(3) by fastforce
    also have "\<dots> = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
    proof -
      have "(\<Sum>m<k. f(m) * unity_root k (-(n+k)*m)) =
            (\<Sum>m<k. f(m) * unity_root k (-n*m))"
        by (intro sum.cong) (use u_period in auto)
      then show ?thesis by argo
    qed
    also have "\<dots> = g(n)"
      using assms(3) by fastforce
    finally show "g(n+k) = g(n)" by simp
  qed

  show "f(m) = (\<Sum>n<k. g(n)* unity_root k (m * int n))"
  proof -
    {
      fix m
      assume range: "m \<in> {0..<k}"
      have "f(m) = (\<Sum>n<k. g(n)* unity_root k (m * int n))"
      proof -
        have "f m = poly (finite_fourier_poly' f k) (unity_root k m)"
          using range by (simp add: poly_finite_fourier_poly')
        also have "\<dots> = (\<Sum>n<k. (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))* unity_root k (m*n))"
          using fourier_unity_root assms(1) by blast
        also have "\<dots> = (\<Sum>n<k. g(n)* unity_root k (m*n))"
          using assms by simp
        finally show ?thesis by auto
    qed}
  note concentrated = this

  have "periodic_arithmetic (\<lambda>m. (\<Sum>n<k. g(n)* unity_root k (m * int n))) k"
  proof -
    have "periodic_arithmetic (\<lambda>n. g(n)* unity_root k (i * int n)) k"  for i :: int
      using 1 unity_periodic_arithmetic mult_periodic_arithmetic
            unity_periodic_arithmetic_mult by auto
    then have p_s: "\<forall>i<k. periodic_arithmetic (\<lambda>n. g(n)* unity_root k (i * int n)) k"
      by simp
    have "periodic_arithmetic (\<lambda>i. \<Sum>n<k. g(n)* unity_root k (i * int n)) k"
      unfolding periodic_arithmetic_def
    proof
      fix n
      show "(\<Sum>na<k. g na * unity_root k (int (n + k) * int na)) =
            (\<Sum>na<k. g na * unity_root k (int n * int na))"
        by (intro sum.cong refl, simp add: distrib_right flip: of_nat_mult of_nat_add)
           (insert period, unfold periodic_arithmetic_def, blast)
    qed
    then show ?thesis by simp
  qed

  from this assms(1-2) concentrated
       unique_periodic_arithmetic_extension[of k f "(\<lambda>i. \<Sum>n<k. g(n)* unity_root k (i * int n))"  m]
  show "f m = (\<Sum>n<k. g n * unity_root k (int m * int n))" by simp
  qed
qed

theorem fourier_expansion_periodic_arithmetic_unique:
  fixes f g :: "nat \<Rightarrow> complex"
  assumes "k > 0"
  assumes "periodic_arithmetic f k" and "periodic_arithmetic g k"
  assumes "\<And>m. m < k \<Longrightarrow> f m = (\<Sum>n<k. g n * unity_root k (int (m * n)))"
  shows   "g n = (1 / k) * (\<Sum>m<k. f m * unity_root k (-n * m))"
proof -
  let ?p = "poly_of_list [g(n). n \<leftarrow> [0..<k]]"
  have d: "degree ?p \<le> k-1"
  proof -
    have "degree ?p \<le> length [g(n). n \<leftarrow> [0..<k]] - 1"
      using degree_poly_of_list_le by blast
    also have "\<dots> = length [0..<k] - 1"
      using length_map by auto
    finally show ?thesis by simp
  qed
  have c: "coeff ?p i = (if i < k then g(i) else 0)" for i
    by (simp add: nth_default_def)
  {fix z
  have "poly ?p z = (\<Sum>n\<le>k-1. coeff ?p n* z^n)"
    using poly_altdef'[of ?p "k-1"] d by blast
  also have "\<dots> = (\<Sum>n<k. coeff ?p n* z^n)"
    using \<open>k > 0\<close> by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>n<k. (if n < k then g(n) else 0)* z^n)"
    using c by simp
  also have "\<dots> = (\<Sum>n<k. g(n)* z^n)"
    by (simp split: if_splits)
  finally have "poly ?p z = (\<Sum>n<k. g n * z ^ n)" .}
  note eval = this
  {fix i
  have "poly ?p (unity_root k i) = (\<Sum>n<k. g(n)* (unity_root k i)^n)"
    using eval by blast
  then have "poly ?p (unity_root k i) = (\<Sum>n<k. g(n)* (unity_root k (i*n)))"
    using unity_root_pow by auto}
  note interpolation = this

  {
    fix m
    assume b: "m \<le> k-1"
    from d assms(1)
    have "f m = (\<Sum>n<k. g(n) * unity_root k (m*n))"
      using assms(4) b by auto
    also have "\<dots> = poly ?p (unity_root k m)"
      using interpolation by simp
    finally have "f m = poly ?p (unity_root k m)" by auto
  }

  from this finite_fourier_poly'_unique[of k _ f]
  have p_is_fourier: "?p = finite_fourier_poly' f k"
    using assms(1) d by blast

  {
    fix n
    assume b: "n \<le> k-1"
    have f_1: "coeff ?p n = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
      using p_is_fourier using assms(1) b by (auto simp: coeff_finite_fourier_poly')
    then have "g(n) = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
      using c b assms(1)
    proof -
      have 1: "coeff ?p n = (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))"
        using f_1 by blast
      have 2: "coeff ?p n =  g n"
        using c assms(1) b by simp
      show ?thesis using 1 2 by argo
    qed
  }

 (* now show right hand side is periodic and use unique_periodic_extension *)
  have "periodic_arithmetic (\<lambda>n. (1 / k) * (\<Sum>m<k. f(m) * unity_root k (-n*m))) k"
  proof -
    have "periodic_arithmetic (\<lambda>i. unity_root k (-int i*int m)) k" for m
      using unity_root_periodic_arithmetic_mult_minus by simp
    then have "periodic_arithmetic (\<lambda>i. f(m) * unity_root k (-i*m)) k" for m
      by (simp add: periodic_arithmetic_def)
    then show "periodic_arithmetic (\<lambda>i. (1 / k) * (\<Sum>m<k. f m * unity_root k (-i*m))) k"
      by (intro scalar_mult_periodic_arithmetic fin_sum_periodic_arithmetic_set) auto
  qed
  note periodich = this
  let ?h = "(\<lambda>i. (1 / k) *(\<Sum>m<k. f m * unity_root k (-i*m)))"
  from unique_periodic_arithmetic_extension[of k g ?h n]
        assms(3) assms(1) periodich
  have "g n = (1/k) * (\<Sum>m<k. f m * unity_root k (-n*m))"
    by (simp add: \<open>\<And>na. na \<le> k - 1 \<Longrightarrow> g na = complex_of_real (1 / real k) * (\<Sum>m<k. f m * unity_root k (- int na * int m))\<close>)
  then show ?thesis by simp
qed

end


theory ExF015
  imports Main
begin

lemma "\<not>(\<forall>x. P x) \<longleftrightarrow> (\<exists>x. \<not>P x)"
proof -
  {
    assume a:"\<not>(\<forall>x. P x)"
    {
      assume b:"\<not>(\<exists>x. \<not>P x)"
      {
        fix aa
        {
          assume "\<not>P aa"
          hence "\<exists>x. \<not>P x" by (rule exI)
          with b have False by contradiction
        }
        hence "\<not>\<not>P aa" by (rule notI)
        hence "P aa" by (rule notnotD)
      }
      hence "\<forall>x. P x" by (rule allI)
      with a have False by contradiction
    }
    hence "\<not>\<not>(\<exists>x. \<not>P x)" by (rule notI)
    hence "\<exists>x. \<not>P x" by (rule notnotD)
  }
  moreover
  {
    assume a:"\<exists>x. \<not>P x"
    {
      assume b:"\<forall>x. P x"
      {
        fix aa
        assume c:"\<not>P aa"
        from b have "P aa" by (rule allE)
        with c have False by contradiction
      }
      with a have False by (rule exE)
    }
    hence "\<not>(\<forall>x. P x)" by (rule notI)
  }
  ultimately show ?thesis by (rule iffI)
qed


subsection "Minimum Edit Distance"

theory Min_Ed_Dist0
imports
  "HOL-Library.IArray"
  "HOL-Library.Code_Target_Numeral"
  "HOL-Library.Product_Lexorder"
  "HOL-Library.RBT_Mapping"
  "../state_monad/State_Main"
  "../heap_monad/Heap_Main"
  Example_Misc
  "../util/Tracing"
  "../util/Ground_Function"
begin

subsubsection "Misc"

text "Executable argmin"

fun argmin :: "('a \<Rightarrow> 'b::order) \<Rightarrow> 'a list \<Rightarrow> 'a" where
"argmin f [a] = a" |
"argmin f (a#as) = (let m = argmin f as in if f a \<le> f m then a else m)"
(* end rm *)

(* Ex: Optimization of argmin *)
fun argmin2 :: "('a \<Rightarrow> 'b::order) \<Rightarrow> 'a list \<Rightarrow> 'a * 'b" where
"argmin2 f [a] = (a, f a)" |
"argmin2 f (a#as) = (let fa = f a; (am,m) = argmin2 f as in if fa \<le> m then (a, fa) else (am,m))"

subsubsection "Edit Distance"

datatype 'a ed = Copy | Repl 'a | Ins 'a | Del

fun edit :: "'a ed list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"edit (Copy # es) (x # xs) = x # edit es xs" |
"edit (Repl a # es) (x # xs) = a # edit es xs" |
"edit (Ins a # es) xs = a # edit es xs" |
"edit (Del # es) (x # xs) = edit es xs" |
"edit (Copy # es) [] = edit es []" |
"edit (Repl a # es) [] = edit es []" |
"edit (Del # es) [] = edit es []" |
"edit [] xs = xs"

abbreviation cost where
"cost es \<equiv> length [e <- es. e \<noteq> Copy]"

subsubsection "Minimum Edit Sequence"

fun min_eds :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a ed list" where
"min_eds [] [] = []" |
"min_eds [] (y#ys) = Ins y # min_eds [] ys" |
"min_eds (x#xs) [] = Del # min_eds xs []" |
"min_eds (x#xs) (y#ys) =
  argmin cost [Ins y # min_eds (x#xs) ys, Del # min_eds xs (y#ys),
     (if x=y then Copy else Repl y) # min_eds xs ys]"

lemma "min_eds ''vintner'' ''writers'' =
  [Ins CHR ''w'', Repl CHR ''r'', Copy, Del, Copy, Del, Copy, Copy, Ins CHR ''s'']"
by eval
(*
value "min_eds ''madagascar'' ''bananas''"

value "min_eds ''madagascaram'' ''banananas''"
*)
lemma min_eds_correct: "edit (min_eds xs ys) xs = ys"
by (induction xs ys rule: min_eds.induct) auto

lemma min_eds_same: "min_eds xs xs = replicate (length xs) Copy"
by (induction xs) auto

lemma min_eds_eq_Nil_iff: "min_eds xs ys = [] \<longleftrightarrow> xs = [] \<and> ys = []"
by (induction xs ys rule: min_eds.induct) auto

lemma min_eds_Nil: "min_eds [] ys = map Ins ys"
by (induction ys) auto

lemma min_eds_Nil2: "min_eds xs [] = replicate (length xs) Del"
by (induction xs) auto

lemma if_edit_Nil2: "edit es ([]::'a list) = ys \<Longrightarrow> length ys \<le> cost es"
apply(induction es "[]::'a list" arbitrary: ys rule: edit.induct)
apply auto
 apply fastforce
apply fastforce
done

lemma if_edit_eq_Nil: "edit es xs = [] \<Longrightarrow> length xs \<le> cost es"
by (induction es xs rule: edit.induct) auto

lemma min_eds_minimal: "edit es xs = ys \<Longrightarrow> cost(min_eds xs ys) \<le> cost es"
proof(induction xs ys arbitrary: es rule: min_eds.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by (auto simp add: min_eds_Nil dest: if_edit_Nil2)
next
  case 3
  thus ?case by(auto simp add: min_eds_Nil2 dest: if_edit_eq_Nil)
next
  case 4
  show ?case
  proof (cases "es")
    case Nil then show ?thesis using "4.prems" by (auto simp: min_eds_same)
  next
    case [simp]: (Cons e es')
    show ?thesis
    proof (cases e)
      case Copy
      thus ?thesis using "4.prems" "4.IH"(3)[of es'] by simp
    next
      case (Repl a)
      thus ?thesis using "4.prems" "4.IH"(3)[of es']
        using [[simp_depth_limit=1]] by simp
    next
      case (Ins a)
      thus ?thesis using "4.prems" "4.IH"(1)[of es']
        using [[simp_depth_limit=1]] by auto
    next
      case Del
      thus ?thesis using "4.prems" "4.IH"(2)[of es']
        using [[simp_depth_limit=1]] by auto
    qed
  qed
qed

subsubsection "Computing the Minimum Edit Distance"

fun min_ed :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
"min_ed [] [] = 0" |
"min_ed [] (y#ys) = 1 + min_ed [] ys" |
"min_ed (x#xs) [] = 1 + min_ed xs []" |
"min_ed (x#xs) (y#ys) =
  Min {1 + min_ed (x#xs) ys, 1 + min_ed xs (y#ys), (if x=y then 0 else 1) + min_ed xs ys}"

lemma min_ed_min_eds: "min_ed xs ys = cost(min_eds xs ys)"
apply(induction xs ys rule: min_ed.induct)
apply (auto split!: if_splits)
done

lemma "min_ed ''madagascar'' ''bananas'' = 6"
by eval
(*
value "min_ed ''madagascaram'' ''banananas''"
*)

text "Exercise: Optimization of the Copy case"

fun min_eds2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a ed list" where
"min_eds2 [] [] = []" |
"min_eds2 [] (y#ys) = Ins y # min_eds2 [] ys" |
"min_eds2 (x#xs) [] = Del # min_eds2 xs []" |
"min_eds2 (x#xs) (y#ys) =
  (if x=y then Copy # min_eds2 xs ys
   else argmin cost
     [Ins y # min_eds2 (x#xs) ys, Del # min_eds2 xs (y#ys), Repl y # min_eds2 xs ys])"

value "min_eds2 ''madagascar'' ''bananas''"

lemma cost_Copy_Del: "cost(min_eds xs ys) \<le> cost (min_eds xs (x#ys)) + 1"
apply(induction xs ys rule: min_eds.induct)
apply(auto simp del: filter_True filter_False split!: if_splits)
done

lemma cost_Copy_Ins: "cost(min_eds xs ys) \<le> cost (min_eds (x#xs) ys) + 1"
apply(induction xs ys rule: min_eds.induct)
apply(auto simp del: filter_True filter_False split!: if_splits)
done

lemma "cost(min_eds2 xs ys) = cost(min_eds xs ys)"
proof(induction xs ys rule: min_eds2.induct)
  case (4 x xs y ys) thus ?case
    apply (auto split!: if_split)
      apply (metis (mono_tags, lifting) Suc_eq_plus1 Suc_leI cost_Copy_Del cost_Copy_Ins le_imp_less_Suc le_neq_implies_less not_less)
     apply (metis Suc_eq_plus1 cost_Copy_Del le_antisym)
    by (metis Suc_eq_plus1 cost_Copy_Ins le_antisym)
qed simp_all

lemma "min_eds2 xs ys = min_eds xs ys"
oops
(* Not proveable because Copy comes last in min_eds but first in min_eds2.
   Can reorder, but the proof still requires the same two lemmas cost_*_* above.
*)

subsubsection "Indexing"

text "Indexing lists"

context
fixes xs ys :: "'a list"
fixes m n :: nat
begin

function (sequential)
  min_ed_ix' :: "nat * nat \<Rightarrow> nat" where
"min_ed_ix' (i,j) =
  (if i \<ge> m then
     if j \<ge> n then 0 else 1 + min_ed_ix' (i,j+1) else
   if j \<ge> n then 1 + min_ed_ix' (i+1, j)
   else
   Min {1 + min_ed_ix' (i,j+1), 1 + min_ed_ix' (i+1, j),
       (if xs!i = ys!j then 0 else 1) + min_ed_ix' (i+1,j+1)})"
by pat_completeness auto
termination by(relation "measure(\<lambda>(i,j). (m - i) + (n - j))") auto

declare min_ed_ix'.simps[simp del]

end

lemma min_ed_ix'_min_ed:
  "min_ed_ix' xs ys (length xs) (length ys) (i, j) = min_ed (drop i xs) (drop j ys)"
apply(induction "(i,j)" arbitrary: i j rule: min_ed_ix'.induct[of "length xs" "length ys"])
apply(subst min_ed_ix'.simps)
apply(simp add: Cons_nth_drop_Suc[symmetric])
done

text "Indexing functions"

context
fixes xs ys :: "nat \<Rightarrow> 'a"
fixes m n :: nat
begin

function (sequential)
  min_ed_ix :: "nat \<times> nat \<Rightarrow> nat" where
"min_ed_ix (i, j) =
  (if i \<ge> m then
     if j \<ge> n then 0 else n-j else
   if j \<ge> n then m-i
   else
   min_list [1 + min_ed_ix (i, j+1), 1 + min_ed_ix (i+1, j),
       (if xs i = ys j then 0 else 1) + min_ed_ix (i+1, j+1)])"
by pat_completeness auto
termination by(relation "measure(\<lambda>(i,j). (m - i) + (n - j))") auto

subsubsection \<open>Functional Memoization\<close>

memoize_fun min_ed_ix\<^sub>m: min_ed_ix with_memory dp_consistency_mapping monadifies (state) min_ed_ix.simps
thm min_ed_ix\<^sub>m'.simps

memoize_correct
  by memoize_prover
print_theorems

lemmas [code] = min_ed_ix\<^sub>m.memoized_correct

declare min_ed_ix.simps[simp del]

subsubsection \<open>Imperative Memoization\<close>

context
  fixes mem :: "nat ref \<times> nat ref \<times> nat option array ref \<times> nat option array ref"
  assumes mem_is_init: "mem = result_of (init_state (n + 1) m (m + 1)) Heap.empty"
begin

interpretation iterator
  "\<lambda> (x, y). x \<le> m \<and> y \<le> n \<and> x > 0"
  "\<lambda> (x, y). if y > 0 then (x, y - 1) else (x - 1, n)"
  "\<lambda> (x, y). (m - x) * (n + 1) + (n - y)"
  by (rule table_iterator_down)

lemma [intro]:
  "dp_consistency_heap_array_pair' (n + 1) fst snd id m (m + 1) mem"
  by (standard; simp add: mem_is_init injective_def)

lemma [intro]:
  "dp_consistency_heap_array_pair_iterator (n + 1) fst snd id m (m + 1) mem
   (\<lambda> (x, y). if y > 0 then (x, y - 1) else (x - 1, n))
   (\<lambda> (x, y). (m - x) * (n + 1) + (n - y))
   (\<lambda> (x, y). x \<le> m \<and> y \<le> n \<and> x > 0)
  "
  by (standard; simp add: mem_is_init injective_def)

memoize_fun min_ed_ix\<^sub>h: min_ed_ix
  with_memory (default_proof) dp_consistency_heap_array_pair_iterator
  where size = "n + 1"
    and key1="fst :: nat \<times> nat \<Rightarrow> nat" and key2="snd :: nat \<times> nat \<Rightarrow> nat"
    and k1="m :: nat" and k2="m + 1 :: nat"
    and to_index = "id :: nat \<Rightarrow> nat"
    and mem = mem
    and cnt = "\<lambda> (x, y). x \<le> m \<and> y \<le> n \<and> x > 0"
    and nxt = "\<lambda> (x::nat, y). if y > 0 then (x, y - 1) else (x - 1, n)"
    and sizef = "\<lambda> (x, y). (m - x) * (n + 1) + (n - y)"
monadifies (heap) min_ed_ix.simps

memoize_correct
  by memoize_prover

lemmas memoized_empty =
  min_ed_ix\<^sub>h.memoized_empty[OF min_ed_ix\<^sub>h.consistent_DP_iter_and_compute[OF min_ed_ix\<^sub>h.crel]]
lemmas iter_heap_unfold = iter_heap_unfold

end (* Fixed Memory *)

end

subsubsection \<open>Test Cases\<close>

abbreviation "slice xs i j \<equiv> map xs [i..<j]"

lemma min_ed_Nil1: "min_ed [] ys = length ys"
by (induction ys) auto

lemma min_ed_Nil2: "min_ed xs [] = length xs"
by (induction xs) auto

(* prove correctness of min_ed_ix directly ? *)
lemma min_ed_ix_min_ed: "min_ed_ix xs ys m n (i,j) = min_ed (slice xs i m) (slice ys j n)"
apply(induction "(i,j)" arbitrary: i j rule: min_ed_ix.induct[of m n])
apply(simp add: min_ed_ix.simps upt_conv_Cons min_ed_Nil1 min_ed_Nil2 Suc_diff_Suc)
done

text \<open>Functional Test Cases\<close>

definition "min_ed_list xs ys = min_ed_ix (\<lambda>i. xs!i) (\<lambda>i. ys!i) (length xs) (length ys) (0,0)"

lemma "min_ed_list ''madagascar'' ''bananas'' = 6"
by eval

definition "min_ed_ia xs ys = (let a = IArray xs; b = IArray ys
  in min_ed_ix (\<lambda>i. a!!i) (\<lambda>i. b!!i) (length xs) (length ys) (0,0))"

lemma "min_ed_ia ''madagascar'' ''bananas'' = 6"
by eval

text \<open>Extracting an Executable Constant for the Imperative Implementation\<close>

ground_function min_ed_ix\<^sub>h'_impl: min_ed_ix\<^sub>h'.simps
termination
  by(relation "measure(\<lambda>(xs, ys, m, n, mem, i, j). (m - i) + (n - j))") auto

lemmas [simp del] = min_ed_ix\<^sub>h'_impl.simps min_ed_ix\<^sub>h'.simps

lemma min_ed_ix\<^sub>h'_impl_def:
  includes heap_monad_syntax
  fixes m n :: nat
  fixes mem :: "nat ref \<times> nat ref \<times> nat option array ref \<times> nat option array ref"
  assumes mem_is_init: "mem = result_of (init_state (n + 1) m (m + 1)) Heap.empty"
  shows "min_ed_ix\<^sub>h'_impl xs ys m n mem = min_ed_ix\<^sub>h' xs ys m n mem"
proof -
  have "min_ed_ix\<^sub>h'_impl xs ys m n mem (i, j) = min_ed_ix\<^sub>h' xs ys m n mem (i, j)" for i j
    apply (induction rule: min_ed_ix\<^sub>h'.induct[OF mem_is_init])
    apply (subst min_ed_ix\<^sub>h'_impl.simps)
    apply (subst min_ed_ix\<^sub>h'.simps[OF mem_is_init])
    apply (solve_cong simp)
    done
  then show ?thesis
    by auto
qed

definition
  "iter_min_ed_ix xs ys m n mem = iterator_defs.iter_heap
    (\<lambda> (x, y). x \<le> m \<and> y \<le> n \<and> x > 0)
    (\<lambda> (x, y). if y > 0 then (x, y - 1) else (x - 1, n))
    (min_ed_ix\<^sub>h'_impl xs ys m n mem)
  "

lemma iter_min_ed_ix_unfold[code]:
  "iter_min_ed_ix xs ys m n mem = (\<lambda> (i, j).
    (if i > 0 \<and> i \<le> m \<and> j \<le> n
     then do {
            min_ed_ix\<^sub>h'_impl xs ys m n mem (i, j);
            iter_min_ed_ix xs ys m n mem (if j > 0 then (i, j - 1) else (i - 1, n))
          }
     else Heap_Monad.return ()))"
  unfolding iter_min_ed_ix_def by (rule ext) (safe, simp add: iter_heap_unfold)

definition
  "min_ed_ix_impl xs ys m n i j = do {
    mem \<leftarrow> (init_state (n + 1) (m::nat) (m + 1) ::
      (nat ref \<times> nat ref \<times> nat option array ref \<times> nat option array ref) Heap);
    iter_min_ed_ix xs ys m n mem (m, n);
    min_ed_ix\<^sub>h'_impl xs ys m n mem (i, j)
  }"

lemma bf_impl_correct:
  "min_ed_ix xs ys m n (i, j) = result_of (min_ed_ix_impl xs ys m n i j) Heap.empty"
  using memoized_empty[OF HOL.refl, of xs ys m n "(i, j)" "\<lambda> _. (m, n)"]
  by (simp add:
      execute_bind_success[OF succes_init_state] min_ed_ix_impl_def min_ed_ix\<^sub>h'_impl_def
      iter_min_ed_ix_def
     )

text \<open>Imperative Test Case\<close>

definition
  "min_ed_ia\<^sub>h xs ys = (let a = IArray xs; b = IArray ys
  in min_ed_ix_impl (\<lambda>i. a!!i) (\<lambda>i. b!!i) (length xs) (length ys) 0 0)"

definition
  "test_case = min_ed_ia\<^sub>h ''madagascar'' ''bananas''"

export_code min_ed_ix in SML module_name Test

code_reflect Test functions test_case

text \<open>One can see a trace of the calls to the memory in the output\<close>
ML \<open>Test.test_case ()\<close>

end


section \<open>Counterclockwise\<close>
theory Counterclockwise
imports "HOL-Analysis.Multivariate_Analysis"
begin
text \<open>\label{sec:counterclockwise}\<close>

subsection \<open>Auxiliary Lemmas\<close>

lemma convex3_alt:
  fixes x y z::"'a::real_vector"
  assumes "0 \<le> a" "0 \<le> b" "0 \<le> c" "a + b + c = 1"
  obtains u v  where "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z = x + u *\<^sub>R (y - x) + v *\<^sub>R (z - x)"
    and "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
proof -
  from convex_hull_3[of x y z] have "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z \<in> convex hull {x, y, z}"
    using assms by auto
  also note convex_hull_3_alt
  finally obtain u v where "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z = x + u *\<^sub>R (y - x) + v *\<^sub>R (z - x)"
    and uv: "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
    by auto
  thus ?thesis ..
qed

lemma (in ordered_ab_group_add) add_nonpos_eq_0_iff:
  assumes x: "0 \<ge> x" and y: "0 \<ge> y"
  shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
proof -
  from add_nonneg_eq_0_iff[of "-x" "-y"] assms
  have "- (x + y) = 0 \<longleftrightarrow> - x = 0 \<and> - y = 0"
    by simp
  also have "(- (x + y) = 0) = (x + y = 0)" unfolding neg_equal_0_iff_equal ..
  finally show ?thesis by simp
qed

lemma sum_nonpos_eq_0_iff:
  fixes f :: "'a \<Rightarrow> 'b::ordered_ab_group_add"
  shows "\<lbrakk>finite A; \<forall>x\<in>A. f x \<le> 0\<rbrakk> \<Longrightarrow> sum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  by (induct set: finite) (simp_all add: add_nonpos_eq_0_iff sum_nonpos)

lemma fold_if_in_set:
  "fold (\<lambda>x m. if P x m then x else m) xs x \<in> set (x#xs)"
  by (induct xs arbitrary: x) auto

subsection \<open>Sort Elements of a List\<close>

locale linorder_list0 = fixes le::"'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

definition "min_for a b = (if le a b then a else b)"

lemma min_for_in[simp]: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> min_for x y \<in> S"
  by (auto simp: min_for_def)

lemma fold_min_eqI1: "fold min_for ys y \<notin> set ys \<Longrightarrow> fold min_for ys y = y"
  using fold_if_in_set[of _ ys y]
  by (auto simp: min_for_def[abs_def])

function selsort where
  "selsort [] = []"
| "selsort (y#ys) = (let
      xm = fold min_for ys y;
      xs' = List.remove1 xm (y#ys)
    in (xm#selsort xs'))"
  by pat_completeness auto
termination
  by (relation "Wellfounded.measure length")
    (auto simp: length_remove1 intro!: fold_min_eqI1 dest!: length_pos_if_in_set)

lemma in_set_selsort_eq: "x \<in> set (selsort xs) \<longleftrightarrow> x \<in> (set xs)"
  by (induct rule: selsort.induct) (auto simp: Let_def intro!: fold_min_eqI1)

lemma set_selsort[simp]: "set (selsort xs) = set xs"
  using in_set_selsort_eq by blast

lemma length_selsort[simp]: "length (selsort xs) = length xs"
proof (induct xs rule: selsort.induct)
  case (2 x xs)
  from 2[OF refl refl]
  show ?case
    unfolding selsort.simps
    by (auto simp: Let_def length_remove1
      simp del: selsort.simps split: if_split_asm
      intro!: Suc_pred
      dest!: fold_min_eqI1)
qed simp

lemma distinct_selsort[simp]: "distinct (selsort xs) = distinct xs"
  by (auto intro!: card_distinct dest!: distinct_card)

lemma selsort_eq_empty_iff[simp]: "selsort xs = [] \<longleftrightarrow> xs = []"
  by (cases xs) (auto simp: Let_def)

inductive sortedP :: "'a list \<Rightarrow> bool" where
  Nil: "sortedP []"
| Cons: "\<forall>y\<in>set ys. le x y \<Longrightarrow> sortedP ys \<Longrightarrow> sortedP (x # ys)"

inductive_cases
  sortedP_Nil: "sortedP []" and
  sortedP_Cons: "sortedP (x#xs)"
inductive_simps
  sortedP_Nil_iff: "sortedP Nil" and
  sortedP_Cons_iff: "sortedP (Cons x xs)"

lemma sortedP_append_iff:
  "sortedP (xs @ ys) = (sortedP xs & sortedP ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
  by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons)

lemma sortedP_appendI:
  "sortedP xs \<Longrightarrow> sortedP ys \<Longrightarrow> (\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> le x y) \<Longrightarrow> sortedP (xs @ ys)"
  by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons)

lemma sorted_nth_less: "sortedP xs \<Longrightarrow> i < j \<Longrightarrow> j < length xs \<Longrightarrow> le (xs ! i) (xs ! j)"
  by (induct xs arbitrary: i j) (auto simp: nth_Cons split: nat.split elim!: sortedP_Cons)

lemma sorted_butlastI[intro, simp]: "sortedP xs \<Longrightarrow> sortedP (butlast xs)"
  by (induct xs) (auto simp: elim!: sortedP_Cons intro!: sortedP.Cons dest!: in_set_butlastD)

lemma sortedP_right_of_append1:
  assumes "sortedP (zs@[z])"
  assumes "y \<in> set zs"
  shows "le y z"
  using assms
  by (induct zs arbitrary: y z) (auto elim!: sortedP_Cons)

lemma sortedP_right_of_last:
  assumes "sortedP zs"
  assumes "y \<in> set zs" "y \<noteq> last zs"
  shows "le y (last zs)"
  using assms
  apply (intro sortedP_right_of_append1[of "butlast zs" "last zs" y])
  subgoal by (metis append_is_Nil_conv list.distinct(1) snoc_eq_iff_butlast split_list)
  subgoal by (metis List.insert_def append_butlast_last_id insert_Nil list.distinct(1) rotate1.simps(2)
    set_ConsD set_rotate1)
  done

lemma selsort_singleton_iff: "selsort xs = [x] \<longleftrightarrow> xs = [x]"
  by (induct xs) (auto simp: Let_def)

lemma hd_last_sorted:
  assumes "sortedP xs" "length xs > 1"
  shows "le (hd xs) (last xs)"
proof (cases xs)
  case (Cons y ys)
  note ys = this
  thus ?thesis
    using ys assms
    by (auto elim!: sortedP_Cons)
qed (insert assms, simp)

end

lemma (in comm_monoid_add) sum_list_distinct_selsort:
  assumes "distinct xs"
  shows "sum_list (linorder_list0.selsort le xs) = sum_list xs"
  using assms
  apply (simp add: distinct_sum_list_conv_Sum linorder_list0.distinct_selsort)
  apply (rule sum.cong)
  subgoal by (simp add: linorder_list0.set_selsort)
  subgoal by simp
  done

declare linorder_list0.sortedP_Nil_iff[code]
  linorder_list0.sortedP_Cons_iff[code]
  linorder_list0.selsort.simps[code]
  linorder_list0.min_for_def[code]

locale linorder_list = linorder_list0 le for le::"'a::ab_group_add \<Rightarrow> _" +
  fixes S
  assumes order_refl: "a \<in> S \<Longrightarrow> le a a"
  assumes trans': "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> c \<in> S \<Longrightarrow> a \<noteq> b \<Longrightarrow> b \<noteq> c \<Longrightarrow> a \<noteq> c \<Longrightarrow>
    le a b \<Longrightarrow> le b c \<Longrightarrow> le a c"
  assumes antisym: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> le a b \<Longrightarrow> le b a \<Longrightarrow> a = b"
  assumes linear': "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<noteq> b \<Longrightarrow> le a b \<or> le b a"
begin

lemma trans: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> c \<in> S \<Longrightarrow> le a b \<Longrightarrow> le b c \<Longrightarrow> le a c"
  by (cases "a = b" "b = c" "a = c"
    rule: bool.exhaust[case_product bool.exhaust[case_product bool.exhaust]])
    (auto simp: order_refl intro: trans')

lemma linear: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> le a b \<or> le b a"
  by (cases "a = b") (auto simp: linear' order_refl)

lemma min_le1: "w \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> le (min_for w y) y"
  and min_le2: "w \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> le (min_for w y) w"
  using linear
  by (auto simp: min_for_def refl)

lemma fold_min:
  assumes "set xs \<subseteq> S"
  shows "list_all (\<lambda>y. le (fold min_for (tl xs) (hd xs)) y) xs"
proof (cases xs)
  case (Cons y ys)
  hence subset: "set (y#ys) \<subseteq> S" using assms
    by auto
  show ?thesis
    unfolding Cons list.sel
    using subset
  proof (induct ys arbitrary: y)
    case (Cons z zs)
    hence IH: "\<And>y. y \<in> S \<Longrightarrow> list_all (le (fold min_for zs y)) (y # zs)"
      by simp
    let ?f = "fold min_for zs (min_for z y)"
    have "?f \<in> set ((min_for z y)#zs)"
      unfolding min_for_def[abs_def]
      by (rule fold_if_in_set)
    also have "\<dots> \<subseteq> S" using Cons.prems by auto
    finally have "?f \<in> S" .

    have "le ?f (min_for z y)"
      using IH[of "min_for z y"] Cons.prems
      by auto
    moreover have "le (min_for z y) y" "le (min_for z y) z" using Cons.prems
      by (auto intro!: min_le1 min_le2)
    ultimately have "le ?f y" "le ?f z" using Cons.prems \<open>?f \<in> S\<close>
      by (auto intro!: trans[of ?f "min_for z y"])
    thus ?case
      using IH[of "min_for z y"]
      using Cons.prems
      by auto
  qed (simp add: order_refl)
qed simp

lemma
  sortedP_selsort:
  assumes "set xs \<subseteq> S"
  shows "sortedP (selsort xs)"
  using assms
proof (induction xs rule: selsort.induct)
  case (2 z zs)
  from this fold_min[of "z#zs"]
  show ?case
    by (fastforce simp: list_all_iff Let_def
        simp del: remove1.simps
        intro: Cons intro!: 2(1)[OF refl refl]
        dest!: rev_subsetD[OF _ set_remove1_subset])+
qed (auto intro!: Nil)

end

subsection \<open>Abstract CCW Systems\<close>

locale ccw_system0 =
  fixes ccw::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
    and S::"'a set"
begin

abbreviation "indelta t p q r \<equiv> ccw t q r \<and> ccw p t r \<and> ccw p q t"
abbreviation "insquare p q r s \<equiv> ccw p q r \<and> ccw q r s \<and> ccw r s p \<and> ccw s p q"

end

abbreviation "distinct3 p q r \<equiv> \<not>(p = q \<or> p = r \<or> q = r)"
abbreviation "distinct4 p q r s \<equiv> \<not>(p = q \<or> p = r \<or> p = s \<or> \<not> distinct3 q r s)"
abbreviation "distinct5 p q r s t \<equiv> \<not>(p = q \<or> p = r \<or> p = s \<or> p = t \<or> \<not> distinct4 q r s t)"

abbreviation "in3 S p q r \<equiv> p \<in> S \<and> q \<in> S \<and> r \<in> S"
abbreviation "in4 S p q r s \<equiv> in3 S p q r \<and> s \<in> S"
abbreviation "in5 S p q r s t \<equiv> in4 S p q r s \<and> t \<in> S"

locale ccw_system12 = ccw_system0 +
  assumes cyclic: "ccw p q r \<Longrightarrow> ccw q r p"
  assumes ccw_antisym: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> ccw p q r \<Longrightarrow> \<not> ccw p r q"

locale ccw_system123 = ccw_system12 +
  assumes nondegenerate: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> ccw p q r \<or> ccw p r q"
begin

lemma not_ccw_eq: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> \<not> ccw p q r \<longleftrightarrow> ccw p r q"
  using ccw_antisym nondegenerate by blast

end

locale ccw_system4 = ccw_system123 +
  assumes interior:
    "distinct4 p q r t \<Longrightarrow> in4 S p q r t \<Longrightarrow> ccw t q r \<Longrightarrow> ccw p t r \<Longrightarrow> ccw p q t \<Longrightarrow> ccw p q r"
begin

lemma interior':
  "distinct4 p q r t \<Longrightarrow> in4 S p q r t \<Longrightarrow> ccw p q t \<Longrightarrow> ccw q r t \<Longrightarrow> ccw r p t \<Longrightarrow> ccw p q r"
  by (metis ccw_antisym cyclic interior nondegenerate)

end

locale ccw_system1235' = ccw_system123 +
  assumes dual_transitive:
    "distinct5 p q r s t \<Longrightarrow> in5 S p q r s t \<Longrightarrow>
      ccw s t p \<Longrightarrow> ccw s t q \<Longrightarrow> ccw s t r \<Longrightarrow> ccw t p q \<Longrightarrow> ccw t q r \<Longrightarrow> ccw t p r"

locale ccw_system1235 = ccw_system123 +
  assumes transitive: "distinct5 p q r s t \<Longrightarrow> in5 S p q r s t \<Longrightarrow>
    ccw t s p \<Longrightarrow> ccw t s q \<Longrightarrow> ccw t s r \<Longrightarrow> ccw t p q \<Longrightarrow> ccw t q r \<Longrightarrow> ccw t p r"
begin

lemmas ccw_axioms = cyclic nondegenerate ccw_antisym transitive

sublocale ccw_system1235'
proof (unfold_locales, rule ccontr, goal_cases)
  case prems: (1 p q r s t)
  hence "ccw s p q \<Longrightarrow> ccw s r p"
    by (metis ccw_axioms prems)
  moreover
  have "ccw s r p \<Longrightarrow> ccw s q r"
    by (metis ccw_axioms prems)
  moreover
  have "ccw s q r \<Longrightarrow> ccw s p q"
    by (metis ccw_axioms prems)
  ultimately
  have "ccw s p q \<and> ccw s r p \<and> ccw s q r \<or> ccw s q p \<and> ccw s p r \<and> ccw s r q"
    by (metis ccw_axioms prems)
  thus False
    by (metis ccw_axioms prems)
qed

end

locale ccw_system = ccw_system1235 + ccw_system4

end