(*  Title:    HOL/Analysis/Integral_Test.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Integral Test for Summability\<close>

theory Integral_Test
imports Henstock_Kurzweil_Integration
begin

text \<open>
  The integral test for summability. We show here that for a decreasing non-negative
  function, the infinite sum over that function evaluated at the natural numbers
  converges iff the corresponding integral converges.

  As a useful side result, we also provide some results on the difference between
  the integral and the partial sum. (This is useful e.g. for the definition of the
  Euler-Mascheroni constant)
\<close>

(* TODO: continuous_in \<rightarrow> integrable_on *)
locale\<^marker>\<open>tag important\<close> antimono_fun_sum_integral_diff =
  fixes f :: "real \<Rightarrow> real"
  assumes dec: "\<And>x y. x \<ge> 0 \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  assumes nonneg: "\<And>x. x \<ge> 0 \<Longrightarrow> f x \<ge> 0"
  assumes cont: "continuous_on {0..} f"
begin

definition "sum_integral_diff_series n = (\<Sum>k\<le>n. f (of_nat k)) - (integral {0..of_nat n} f)"

lemma sum_integral_diff_series_nonneg:
  "sum_integral_diff_series n \<ge> 0"
proof -
  note int = integrable_continuous_real[OF continuous_on_subset[OF cont]]
  let ?int = "\<lambda>a b. integral {of_nat a..of_nat b} f"
  have "-sum_integral_diff_series n = ?int 0 n - (\<Sum>k\<le>n. f (of_nat k))"
    by (simp add: sum_integral_diff_series_def)
  also have "?int 0 n = (\<Sum>k<n. ?int k (Suc k))"
  proof (induction n)
    case (Suc n)
    have "?int 0 (Suc n) = ?int 0 n + ?int n (Suc n)"
      by (intro integral_combine[symmetric] int) simp_all
    with Suc show ?case by simp
  qed simp_all
  also have "... \<le> (\<Sum>k<n. integral {of_nat k..of_nat (Suc k)} (\<lambda>_::real. f (of_nat k)))"
    by (intro sum_mono integral_le int) (auto intro: dec)
  also have "... = (\<Sum>k<n. f (of_nat k))" by simp
  also have "\<dots> - (\<Sum>k\<le>n. f (of_nat k)) = -(\<Sum>k\<in>{..n} - {..<n}. f (of_nat k))"
    by (subst sum_diff) auto
  also have "\<dots> \<le> 0" by (auto intro!: sum_nonneg nonneg)
  finally show "sum_integral_diff_series n \<ge> 0" by simp
qed

lemma sum_integral_diff_series_antimono:
  assumes "m \<le> n"
  shows   "sum_integral_diff_series m \<ge> sum_integral_diff_series n"
proof -
  let ?int = "\<lambda>a b. integral {of_nat a..of_nat b} f"
  note int = integrable_continuous_real[OF continuous_on_subset[OF cont]]
  have d_mono: "sum_integral_diff_series (Suc n) \<le> sum_integral_diff_series n" for n
  proof -
    fix n :: nat
    have "sum_integral_diff_series (Suc n) - sum_integral_diff_series n =
            f (of_nat (Suc n)) + (?int 0 n - ?int 0 (Suc n))"
      unfolding sum_integral_diff_series_def by (simp add: algebra_simps)
    also have "?int 0 n - ?int 0 (Suc n) = -?int n (Suc n)"
      by (subst integral_combine [symmetric, of "of_nat 0" "of_nat n" "of_nat (Suc n)"])
         (auto intro!: int simp: algebra_simps)
    also have "?int n (Suc n) \<ge> integral {of_nat n..of_nat (Suc n)} (\<lambda>_::real. f (of_nat (Suc n)))"
      by (intro integral_le int) (auto intro: dec)
    hence "f (of_nat (Suc n)) + -?int n (Suc n) \<le> 0" by (simp add: algebra_simps)
    finally show "sum_integral_diff_series (Suc n) \<le> sum_integral_diff_series n" by simp
  qed
  with assms show ?thesis
    by (induction rule: inc_induct) (auto intro: order.trans[OF _ d_mono])
qed

lemma sum_integral_diff_series_Bseq: "Bseq sum_integral_diff_series"
proof -
  from sum_integral_diff_series_nonneg and sum_integral_diff_series_antimono
    have "norm (sum_integral_diff_series n) \<le> sum_integral_diff_series 0" for n by simp
  thus "Bseq sum_integral_diff_series" by (rule BseqI')
qed

lemma sum_integral_diff_series_monoseq: "monoseq sum_integral_diff_series"
  using sum_integral_diff_series_antimono unfolding monoseq_def by blast

lemma sum_integral_diff_series_convergent: "convergent sum_integral_diff_series"
  using sum_integral_diff_series_Bseq sum_integral_diff_series_monoseq
  by (blast intro!: Bseq_monoseq_convergent)

theorem integral_test:
  "summable (\<lambda>n. f (of_nat n)) \<longleftrightarrow> convergent (\<lambda>n. integral {0..of_nat n} f)"
proof -
  have "summable (\<lambda>n. f (of_nat n)) \<longleftrightarrow> convergent (\<lambda>n. \<Sum>k\<le>n. f (of_nat k))"
    by (simp add: summable_iff_convergent')
  also have "... \<longleftrightarrow> convergent (\<lambda>n. integral {0..of_nat n} f)"
  proof
    assume "convergent (\<lambda>n. \<Sum>k\<le>n. f (of_nat k))"
    from convergent_diff[OF this sum_integral_diff_series_convergent]
      show "convergent (\<lambda>n. integral {0..of_nat n} f)"
        unfolding sum_integral_diff_series_def by simp
  next
    assume "convergent (\<lambda>n. integral {0..of_nat n} f)"
    from convergent_add[OF this sum_integral_diff_series_convergent]
      show "convergent (\<lambda>n. \<Sum>k\<le>n. f (of_nat k))" unfolding sum_integral_diff_series_def by simp
  qed
  finally show ?thesis by simp
qed

end

end


theory Exercise_2_9
imports Main
begin
fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 0 x = x" |
  "itadd n (Suc m) x = itadd n m (Suc x)" |
  "itadd (Suc m) n x = itadd m n (Suc x)"

value "itadd 3 7 0"

lemma itadd_1: "itadd m 0 k = m + k"
  apply(induction m arbitrary: k)
  apply(auto)
  done

lemma "itadd m n k = m + n + k"
  apply(induction m; induction n arbitrary: k)
  apply(auto simp add: itadd_1)
  done


chapter \<open>Auxiliary Lemma Library\<close>
theory IPP_Lib
imports IMPlusPlus "~~/src/HOL/Library/Multiset"
begin

text \<open>This library contains auxiliary lemmas, which are useful for proving
  various VCs.

  The locale declares some more simplification lemmas.
\<close>

locale Vcg_Aux_Lemmas

section \<open>Conversion between Nat and Int\<close>
lemmas (in Vcg_Aux_Lemmas) [simp] = nat_add_distrib

lemma int_minus_minus_eq: "(n\<^sub>0 - (n - 1)) = (n\<^sub>0 - (n::int)) + 1"
  by linarith

lemma nat_minus_minus_eq_Suc:
  "0\<le>n \<and> n\<le>n\<^sub>0 \<Longrightarrow> nat (n\<^sub>0 - (n - 1)) = Suc (nat (n\<^sub>0-n))"
  -- \<open>Useful for count-down loop schemes\<close>
  by linarith

lemma int_plus_int_eq_int: "int a + int b = int (c) \<longleftrightarrow> a+b = c" by auto

lemmas (in Vcg_Aux_Lemmas) [simp] =
  int_plus_int_eq_int nat_minus_minus_eq_Suc int_minus_minus_eq

section \<open>Interval Sets\<close>

lemma intvs_singleton[simp]:
  "{i::int..<i + 1} = {i}"
  "{i-1..<i::int} = {i-1}"
  by auto

lemma intvs_incr_h:
  "l\<le>h \<Longrightarrow> {l::int..<h + 1} = insert h {l..<h}"
  by auto

lemma intvs_decr_h:
  "{l::int..<h - 1} = {l..<h} - {h-1}"
  by auto

lemma intvs_incr_l:
  "{l+1..<h::int} = {l..<h} - {l}"
  by auto

lemma intvs_decr_l:
  "l\<le>h \<Longrightarrow> {l-1..<h::int} = insert (l-1) {l..<h}"
  by auto

lemmas intvs_incdec = intvs_incr_h intvs_incr_l intvs_decr_h intvs_decr_l

lemma intvs_lower_incr: "l<h \<Longrightarrow> {l::int..<h} = insert l ({l+1..<h})" by auto
lemma intvs_upper_decr: "l<h \<Longrightarrow> {l::int..<h} = insert (h-1) ({l..<h-1})" by auto

section \<open>Induction on Intervals\<close>

function intv_fwd_induct_scheme :: "int \<Rightarrow> int \<Rightarrow> unit" where
  "intv_fwd_induct_scheme l h = (if l<h then intv_fwd_induct_scheme (l+1) h else ())"
  by pat_completeness auto
termination apply (relation "measure (\<lambda>(l,h). nat (h-l))") by auto
lemmas intv_induct = intv_fwd_induct_scheme.induct[case_names incr]

function intv_bwd_induct_scheme :: "int \<Rightarrow> int \<Rightarrow> unit" where
  "intv_bwd_induct_scheme l h = (if l<h then intv_bwd_induct_scheme l (h-1) else ())"
  by pat_completeness auto
termination apply (relation "measure (\<lambda>(l,h). nat (h-l))") by auto
lemmas intv_bwd_induct = intv_bwd_induct_scheme.induct[case_names decr]

section \<open>Multiset Lemmas\<close>

section \<open>Multiset of Ranges in Arrays\<close>
definition mset_ran :: "(int \<Rightarrow> 'a) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a multiset"
  where "mset_ran a l h \<equiv> image_mset a (mset_set {l..<h})"

lemma mset_ran_by_sum: "mset_ran a l h = (\<Sum>i=l..<h. {#a i#})"
proof (induction l h rule: intv_induct)
  case (incr l h)
  then show ?case
    unfolding mset_ran_def
    by (cases "l<h") (auto simp: intvs_lower_incr)

qed

lemma mset_ran_mem[simp, intro]: "i\<in>{l..<h} \<Longrightarrow> a i \<in># mset_ran a l h"
  by (auto simp: mset_ran_def)

lemma mset_ran_empty[simp]:
  "mset_ran a l l = {#}"
  by (auto simp: mset_ran_def)

lemma mset_ran_empty_iff[simp]:
  "mset_ran a l h = {#} \<longleftrightarrow> h\<le>l"
  by (auto simp: mset_ran_def mset_set_empty_iff)

lemma mset_ran_subst_outside: "i\<notin>{l..<h} \<Longrightarrow> mset_ran (a(i:=x)) l h = mset_ran a l h"
  unfolding mset_ran_def by (auto simp: image_mset_subst_outside)

lemma mset_ran_subst_inside: "i\<in>{l..<h} \<Longrightarrow> mset_ran (a(i:=x)) l h = mset_ran a l h + {#x#} - {#a i#}"
  unfolding mset_ran_def by (auto simp: image_mset_set_subst_inside)

lemma mset_ran_combine: "\<lbrakk>i\<le>j; j\<le>k\<rbrakk> \<Longrightarrow> mset_ran a i j + mset_ran a j k = mset_ran a i k"
  by (auto simp: mset_ran_by_sum sum.union_disjoint[symmetric] ivl_disj_un)

lemma mset_ran_cong:
  "a = b on {l..<h} \<Longrightarrow> mset_ran a l h = mset_ran b l h"
  by (auto simp: mset_ran_by_sum eq_on_def)

lemma extend_range:
  assumes BOUNDS: "l\<le>h" "h\<le>h'"
  assumes EQ1: "mset_ran a l h = mset_ran a\<^sub>0 l h"
  assumes EQ2: "a = a\<^sub>0 on {h..<h'}"
  shows "mset_ran a l h' = mset_ran a\<^sub>0 l h'"
  using EQ1 mset_ran_cong[OF EQ2]
    mset_ran_combine[OF BOUNDS, of a]
    mset_ran_combine[OF BOUNDS, of a\<^sub>0]
    by simp

end


(*  Title:      HOL/Old_Number_Theory/IntFact.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Factorial on integers *}

theory IntFact
imports IntPrimes
begin

text {*
  Factorial on integers and recursively defined set including all
  Integers from @{text 2} up to @{text a}.  Plus definition of product
  of finite set.

  \bigskip
*}

fun zfact :: "int => int"
  where "zfact n = (if n \<le> 0 then 1 else n * zfact (n - 1))"

fun d22set :: "int => int set"
  where "d22set a = (if 1 < a then insert a (d22set (a - 1)) else {})"

text {*
  \medskip @{term d22set} --- recursively defined set including all
  integers from @{text 2} up to @{text a}
*}

declare d22set.simps [simp del]

lemma d22set_induct:
  assumes "!!a. P {} a"
    and "!!a. 1 < (a::int) ==> P (d22set (a - 1)) (a - 1) ==> P (d22set a) a"
  shows "P (d22set u) u"
  apply (rule d22set.induct)
  apply (case_tac "1 < a")
   apply (rule_tac assms)
    apply (simp_all (no_asm_simp))
  apply (simp_all (no_asm_simp) add: d22set.simps assms)
  done

lemma d22set_g_1 [rule_format]: "b \<in> d22set a --> 1 < b"
  apply (induct a rule: d22set_induct)
   apply simp
  apply (subst d22set.simps)
  apply auto
  done

lemma d22set_le [rule_format]: "b \<in> d22set a --> b \<le> a"
  apply (induct a rule: d22set_induct)
  apply simp
   apply (subst d22set.simps)
   apply auto
  done

lemma d22set_le_swap: "a < b ==> b \<notin> d22set a"
  by (auto dest: d22set_le)

lemma d22set_mem: "1 < b \<Longrightarrow> b \<le> a \<Longrightarrow> b \<in> d22set a"
  apply (induct a rule: d22set.induct)
  apply auto
  apply (subst d22set.simps)
  apply (case_tac "b < a", auto)
  done

lemma d22set_fin: "finite (d22set a)"
  apply (induct a rule: d22set_induct)
   prefer 2
   apply (subst d22set.simps)
   apply auto
  done

declare zfact.simps [simp del]

lemma d22set_prod_zfact: "\<Prod>(d22set a) = zfact a"
  apply (induct a rule: d22set.induct)
  apply (subst d22set.simps)
  apply (subst zfact.simps)
  apply (case_tac "1 < a")
   prefer 2
   apply (simp add: d22set.simps zfact.simps)
  apply (simp add: d22set_fin d22set_le_swap)
  done

end


section \<open>Ferrari's formula for solving quartic equations\<close>

theory Ferraris_Formula
  imports
    Polynomial_Factorization.Explicit_Roots
    Polynomial_Interpolation.Ring_Hom_Poly
    Complex_Geometry.More_Complex
begin

subsection \<open>Translation to depressed case\<close>

text \<open>Solving an arbitrary quartic equation can easily be turned into the depressed case, i.e., where
  there is no cubic part.\<close>

lemma to_depressed_quartic: fixes a4 :: "'a :: field_char_0"
  assumes a4: "a4 \<noteq> 0"
  and b: "b = a3 / a4"
  and c: "c = a2 / a4"
  and d: "d = a1 / a4"
  and e: "e = a0 / a4"
  and p: "p = c - (3/8) * b^2"
  and q: "q = (b^3 - 4*b*c + 8 * d) / 8"
  and r: "r = ( -3 * b^4 + 256 * e - 64 * b * d + 16 * b^2 * c) / 256"
  and x: "x = y - b/4"
shows "a4 * x^4 + a3 * x^3 + a2 * x^2 + a1 * x + a0 = 0
  \<longleftrightarrow> y^4 + p * y^2 + q * y + r = 0"
proof -
  have "a4 * x^4 + a3 * x^3 + a2 * x^2 + a1 * x + a0 = 0 \<longleftrightarrow>
    (a4 * x^4 + a3 * x^3 + a2 * x^2 + a1 * x + a0) / a4 = 0" using a4 by auto
  also have "(a4 * x^4 + a3 * x^3 + a2 * x^2 + a1 * x + a0) / a4
    = x^4 + b * x^3 + c * x^2 + d * x + e"
    unfolding b c d e using a4 by (simp add: field_simps)
  also have "\<dots> = y^4 + p * y^2 + q * y + r"
    unfolding x p q r
    by (simp add: field_simps power4_eq_xxxx power3_eq_cube power2_eq_square)
  finally show ?thesis .
qed

lemma biquadratic_solution: fixes p q :: "'a :: field_char_0"
  shows "y^4 + p * y^2 + q = 0 \<longleftrightarrow> (\<exists> z. z^2 + p * z + q = 0 \<and> z = y^2)"
  by (auto simp: field_simps power4_eq_xxxx power2_eq_square)

subsection \<open>Solving the depressed case via Ferrari's formula\<close>

lemma depressed_quartic_Ferrari: fixes p q r :: "'a :: field_char_0"
  assumes cubic_root: "8*m^3 + (8 * p) * m^2 + (2 * p^2 - 8 * r) * m - q^2 = 0"
  and q0: "q \<noteq> 0"  \<comment> \<open>otherwise m might be zero, so a is zero and then there is a division by zero in b1 and b2\<close>
  and sqrt: "a * a = 2 * m"  (* a = sqrt(2m), where the square-root might not be defined *)
  and b1: "b1 = p / 2 + m - q / (2 * a)"
  and b2: "b2 = p / 2 + m + q / (2 * a)"
  shows "y^4 + p * y^2 + q * y + r = 0 \<longleftrightarrow> poly [:b1,a,1:] y = 0 \<or> poly [:b2,-a,1:] y = 0"
proof -
  let ?N = "y^2 + p / 2 + m"
  let ?M = "a * y - q / (2 * a)"
  from cubic_root q0 have m0: "m \<noteq> 0" by auto
  from sqrt m0 have a0: "a \<noteq> 0" by auto
  define N where "N = ?N"
  define M where "M = ?M"
  note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
  from cubic_root have "8*m^3 = - (8 * p) * m^2 - (2 * p^2 - 8 * r) * m + q^2"
    by (simp add: powers)
  from arg_cong[OF this, of "(*) 4"]
  have id: "32 * m^3 = 4 * (- (8 * p) * m^2 - (2 * p^2 - 8 * r) * m + q^2)" by simp
  let ?add = "2 * y^2 * m + p * m + m^2"
  have "y^4 + p * y^2 + q * y + r = 0 \<longleftrightarrow>
      (y^2 + p / 2)^2 = -q * y - r + p^2 / 4"
    by (simp add: powers, algebra)
  also have "\<dots> \<longleftrightarrow> (y^2 + p / 2)^2 + ?add = -q * y - r + p^2 / 4 + ?add" by simp
  also have "\<dots> \<longleftrightarrow> ?N^2 = 2 * m * y^2 - q * y + m^2 + m * p + p^2 / 4 - r"
    by (simp add: powers)
  also have "2 * m * y^2 - q * y + m^2 + m * p + p^2 / 4 - r =
         ?M ^ 2" using m0 id a0 sqrt by (simp add: powers, algebra)
  also have "?N^2 = ?M^2 \<longleftrightarrow> (?N + ?M) * (?N - ?M) = 0"
    unfolding N_def[symmetric] M_def[symmetric] by algebra
  also have "\<dots> \<longleftrightarrow> ?N + ?M = 0 \<or> ?N - ?M = 0" by simp
  also have "?N + ?M = y\<^sup>2 + a * y + b1"
    by (simp add: b1)
  also have "?N - ?M = y\<^sup>2 - a * y + b2"
    by (simp add: b2)
  also have "y\<^sup>2 + a * y + b1 = 0 \<longleftrightarrow> poly [:b1,a,1:] y = 0"
    by (simp add: powers)
  also have "y\<^sup>2 - a * y + b2 = 0 \<longleftrightarrow> poly [:b2,-a,1:] y = 0"
    by (simp add: powers)
  finally show ?thesis .
qed

end


(*
  File:     Comparison_Sort_Lower_Bound.thy
  Author:   Manuel Eberl <eberlm@in.tum.de>

  Proof of the lower-bound on worst-case comparisons in a comparison-based sorting algorithm.
*)
section \<open>Lower bound on costs of comparison-based sorting\<close>
theory Comparison_Sort_Lower_Bound
  imports
    Complex_Main
    Linorder_Relations
    Stirling_Formula.Stirling_Formula
    "Landau_Symbols.Landau_More"
begin

subsection \<open>Abstract description of sorting algorithms\<close>

text \<open>
  We have chosen to model a sorting algorithm in the following way: A sorting algorithm takes a
  list with distinct elements and a linear ordering on these elements, and it returns a list
  with the same elements that is sorted w.\,r.\,t.\ the given ordering.

  The use of an explicit ordering means that the algorithm must look at the ordering, i.\,e.\
  it has to use pair-wise comparison of elements, since all the information that is relevant
  for producing the correct sorting is in the ordering; the elements themselves are irrelevant.

  Furthermore, we record the number of comparisons that the algorithm makes by not giving it the
  relation explicitly, but in the form of a comparison oracle that may be queried.

  A sorting algorithm (or `sorter') for a fixed input list (but for arbitrary orderings) can then
  be written as a recursive datatype that is either the result (the sorted list) or a comparison
  query consisting of two elements and a continuation that maps the result of the comparison
  to the remaining computation.
\<close>

datatype 'a sorter = Return "'a list" | Query 'a 'a "bool \<Rightarrow> 'a sorter"

text \<open>
  Cormen~\emph{et\ al.}~\cite{cormen}\ use a similar `decision tree' model where an sorting
  algorithm for lists of fixed size $n$ is modelled as a binary tree where each node is a
  comparison of two elements. They also demand that every leaf in the tree be reachable in
  order to avoid `dead' subtrees (if the algorithm makes redundant comparisons, there may be
  branches that can never be taken). Then, the worst-case number of comparisons made is simply
  the height of the tree.

  We chose a subtly different model that does not have this restriction on the algorithm but
  instead uses a more semantic way of counting the worst-case number of comparisons: We simply
  use the maximum number of comparisons that occurs for any of the (finitely many) inputs.

  We therefore first define a function that counts the number of queries for a specific
  ordering and then a function that counts the number of queries in the worst case (ranging
  over a given set of allowed orderings; typically, this will be the set of all linear orders
  on the list).
\<close>
primrec count_queries :: "('a \<times> 'a) set \<Rightarrow> 'a sorter \<Rightarrow> nat" where
  "count_queries _ (Return _)    = 0"
| "count_queries R (Query a b f) = Suc (count_queries R (f ((a, b) \<in> R)))"

definition count_wc_queries :: "('a \<times> 'a) set set \<Rightarrow> 'a sorter \<Rightarrow> nat" where
  "count_wc_queries Rs sorter = (if Rs = {} then 0 else Max ((\<lambda>R. count_queries R sorter) ` Rs))"

lemma count_wc_queries_empty [simp]: "count_wc_queries {} sorter = 0"
  by (simp add: count_wc_queries_def)

lemma count_wc_queries_aux:
  assumes "\<And>R. R \<in> Rs \<Longrightarrow> sorter = sorter' R" "Rs \<subseteq> Rs'" "finite Rs'"
  shows   "count_wc_queries Rs sorter \<le> Max ((\<lambda>R. count_queries R (sorter' R)) ` Rs')"
proof (cases "Rs = {}")
  case False
  hence "count_wc_queries Rs sorter = Max ((\<lambda>R. count_queries R sorter) ` Rs)"
    by (simp add: count_wc_queries_def)
  also have "(\<lambda>R. count_queries R sorter) ` Rs = (\<lambda>R. count_queries R (sorter' R)) ` Rs"
    by (intro image_cong refl) (simp_all add: assms)
  also have "Max \<dots> \<le> Max ((\<lambda>R. count_queries R (sorter' R)) ` Rs')" using False
    by (intro Max_mono assms image_mono finite_imageI) auto
  finally show ?thesis .
qed simp_all

primrec eval_sorter :: "('a \<times> 'a) set \<Rightarrow> 'a sorter \<Rightarrow> 'a list" where
  "eval_sorter _ (Return ys)   = ys"
| "eval_sorter R (Query a b f) = eval_sorter R (f ((a,b) \<in> R))"

text \<open>
  We now get an obvious bound on the maximum number of different results that a given sorter
  can produce.
\<close>
lemma card_range_eval_sorter:
  assumes "finite Rs"
  shows   "card ((\<lambda>R. eval_sorter R e) ` Rs) \<le> 2 ^ count_wc_queries Rs e"
using assms
proof (induction e arbitrary: Rs)
  case (Return xs Rs)
  have *: "(\<lambda>R. eval_sorter R (Return xs)) ` Rs = (if Rs = {} then {} else {xs})" by auto
  show ?case by (subst *) auto
next
  case (Query a b f Rs)
  have "f True \<in> range f" "f False \<in> range f" by simp_all
  note IH = this [THEN Query.IH]
  let ?Rs1 = "{R\<in>Rs. (a, b) \<in> R}" and ?Rs2 = "{R\<in>Rs. (a, b) \<notin> R}"
  let ?A = "(\<lambda>R. eval_sorter R (f True)) ` ?Rs1" and ?B = "(\<lambda>R. eval_sorter R (f False)) ` ?Rs2"
  from Query.prems have fin: "finite ?Rs1" "finite ?Rs2" by simp_all

  have *: "(\<lambda>R. eval_sorter R (Query a b f)) ` Rs \<subseteq> ?A \<union> ?B"
  proof (intro subsetI, elim imageE, goal_cases)
    case (1 xs R)
    thus ?case by (cases "(a,b) \<in> R") auto
  qed

  show ?case
  proof (cases "Rs = {}")
    case False
    have "card ((\<lambda>R. eval_sorter R (Query a b f)) ` Rs) \<le> card (?A \<union> ?B)"
      by (intro card_mono finite_UnI finite_imageI fin *)
    also have "\<dots> \<le> card ?A + card ?B" by (rule card_Un_le)
    also have "\<dots> \<le> 2 ^ count_wc_queries ?Rs1 (f True) + 2 ^ count_wc_queries ?Rs2 (f False)"
      by (intro add_mono IH fin)
    also have "count_wc_queries ?Rs1 (f True) \<le> Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)"
      by (intro count_wc_queries_aux Query.prems) auto
    also have "count_wc_queries ?Rs2 (f False) \<le> Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)"
      by (intro count_wc_queries_aux Query.prems) auto
    also have "2 ^ \<dots> + 2 ^ \<dots> = (2 ^ Suc \<dots> :: nat)" by simp
    also have "Suc (Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)) =
                 Max (Suc ` ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs))" using False
      by (intro mono_Max_commute finite_imageI Query.prems) (auto simp: incseq_def)
    also have "Suc ` ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs) =
                 (\<lambda>R. Suc (count_queries R (f ((a,b)\<in>R)))) ` Rs" by (simp add: image_image)
    also have "Max \<dots> = count_wc_queries Rs (Query a b f)" using False
      by (auto simp add: count_wc_queries_def)
    finally show ?thesis by - simp_all
  qed simp_all
qed

text \<open>
  The following predicate describes what constitutes a valid sorting result for a given
  ordering and a given input list. Note that when the ordering is linear, the result is
  actually unique.
\<close>
definition is_sorting :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "is_sorting R xs ys \<longleftrightarrow> (mset xs = mset ys) \<and> sorted_wrt R ys"

subsection \<open>Lower bounds on number of comparisons\<close>

text \<open>
  For a list of $n$ distinct elements, there are $n!$ linear orderings on $n$ elements,
  each of which leads to a different result after sorting the original list.
  Since a sorter can produce at most $2^k$ different results with $k$ comparisons, we get
  the bound $2^k \geq n!$:
\<close>
theorem
  fixes sorter :: "'a sorter" and xs :: "'a list"
  assumes distinct: "distinct xs"
  assumes sorter: "\<And>R. linorder_on (set xs) R \<Longrightarrow> is_sorting R xs (eval_sorter R sorter)"
  defines "Rs \<equiv> {R. linorder_on (set xs) R}"
  shows   two_power_count_queries_ge: "fact (length xs) \<le> (2 ^ count_wc_queries Rs sorter :: nat)"
    and   count_queries_ge:           "log 2 (fact (length xs)) \<le> real (count_wc_queries Rs sorter)"
proof -
  have "Rs \<subseteq> Pow (set xs \<times> set xs)" by (auto simp: Rs_def linorder_on_def refl_on_def)
  hence fin: "finite Rs" by (rule finite_subset) simp_all
  from assms have "fact (length xs) = card (permutations_of_set (set xs))"
    by (simp add: distinct_card)
  also have "permutations_of_set (set xs) \<subseteq> (\<lambda>R. eval_sorter R sorter) ` Rs"
  proof (rule subsetI, goal_cases)
    case (1 ys)
    define R where "R = linorder_of_list ys"
    define zs where "zs = eval_sorter R sorter"
    from 1 and distinct have mset_ys: "mset ys = mset xs"
      by (auto simp: set_eq_iff_mset_eq_distinct permutations_of_set_def)
    from 1 have *: "linorder_on (set xs) R" unfolding R_def using linorder_linorder_of_list[of ys]
      by (simp add: permutations_of_set_def)
    from sorter[OF this] have "mset xs = mset zs" "sorted_wrt R zs"
      by (simp_all add: is_sorting_def zs_def)
    moreover from 1 have "sorted_wrt R ys" unfolding R_def
      by (intro sorted_wrt_linorder_of_list) (simp_all add: permutations_of_set_def)
    ultimately have "zs = ys"
      by (intro sorted_wrt_linorder_unique[OF *]) (simp_all add: mset_ys)
    moreover from * have "R \<in> Rs" by (simp add: Rs_def)
    ultimately show ?case unfolding zs_def by blast
  qed
  hence "card (permutations_of_set (set xs)) \<le> card ((\<lambda>R. eval_sorter R sorter) ` Rs)"
    by (intro card_mono finite_imageI fin)
  also from fin have "\<dots> \<le> 2 ^ count_wc_queries Rs sorter" by (rule card_range_eval_sorter)
  finally show *: "fact (length xs) \<le> (2 ^ count_wc_queries Rs sorter :: nat)" .

  have "ln (fact (length xs)) = ln (real (fact (length xs)))" by simp
  also have "\<dots> \<le> ln (real (2 ^ count_wc_queries Rs sorter))"
  proof (subst ln_le_cancel_iff)
    show "real (fact (length xs)) \<le> real (2 ^ count_wc_queries Rs sorter)"
      by (subst of_nat_le_iff) (rule *)
  qed simp_all
  also have "\<dots> = real (count_wc_queries Rs sorter) * ln 2" by (simp add: ln_realpow)
  finally have "real (count_wc_queries Rs sorter) \<ge> ln (fact (length xs)) / ln 2"
    by (simp add: field_simps)
  also have "ln (fact (length xs)) / ln 2 = log 2 (fact (length xs))" by (simp add: log_def)
  finally show **: "log 2 (fact (length xs)) \<le> real (count_wc_queries Rs sorter)" .
qed

(* TODO: Good example for automation. Also, move. *)
lemma ln_fact_bigo: "(\<lambda>n. ln (fact n) - (ln (2 * pi * n) / 2 + n * ln n - n)) \<in> O(\<lambda>n. 1 / n)"
  and asymp_equiv_ln_fact [asymp_equiv_intros]: "(\<lambda>n. ln (fact n)) \<sim>[at_top] (\<lambda>n. n * ln n)"
proof -
  include asymp_equiv_notation
  define f where "f = (\<lambda>n. ln (2 * pi * real n) / 2 + real n * ln (real n) - real n)"
  have "eventually (\<lambda>n. ln (fact n) - f n \<in> {0..1/(12*real n)}) at_top"
    using eventually_gt_at_top[of "1::nat"]
  proof eventually_elim
    case (elim n)
    with ln_fact_bounds[of n] show ?case by (simp add: f_def)
  qed
  hence "eventually (\<lambda>n. norm (ln (fact n) - f n) \<le> (1/12) * norm (1 / real n)) at_top"
    using eventually_gt_at_top[of "0::nat"] by eventually_elim (simp_all add: field_simps)
  thus "(\<lambda>n. ln (fact n) - f n) \<in> O(\<lambda>n. 1 / real n)"
    using bigoI[of "\<lambda>n. ln (fact n) - f n" "1/12" "\<lambda>n. 1 / real n"] by simp
  also have "(\<lambda>n. 1 / real n) \<in> o(f)" unfolding f_def by (intro smallo_real_nat_transfer) simp
  finally have "(\<lambda>n. f n + (ln (fact n) - f n)) \<sim> f"
    by (subst asymp_equiv_add_right) simp_all
  hence "(\<lambda>n. ln (fact n)) \<sim> f" by simp
  also have "f \<sim> (\<lambda>n. n * ln n + (ln (2*pi*n)/2 - n))" by (simp add: f_def algebra_simps)
  also have "\<dots> \<sim> (\<lambda>n. n * ln n)" by (subst asymp_equiv_add_right) auto
  finally show "(\<lambda>n. ln (fact n)) \<sim> (\<lambda>n. n * ln n)" .
qed

text \<open>
  This leads to the following well-known Big-Omega bound on the number of comparisons
  that a general sorting algorithm has to make:
\<close>
corollary count_queries_bigomega:
  fixes sorter :: "nat \<Rightarrow> nat sorter"
  assumes sorter: "\<And>n R. linorder_on {..<n} R \<Longrightarrow>
                         is_sorting R [0..<n] (eval_sorter R (sorter n))"
  defines "Rs \<equiv> \<lambda>n. {R. linorder_on {..<n} R}"
  shows   "(\<lambda>n. count_wc_queries (Rs n) (sorter n)) \<in> \<Omega>(\<lambda>n. n * ln n)"
proof -
  have "(\<lambda>n. n * ln n) \<in> \<Theta>(\<lambda>n. ln (fact n))"
    by (subst bigtheta_sym) (intro asymp_equiv_imp_bigtheta asymp_equiv_intros)
  also have "(\<lambda>n. ln (fact n)) \<in> \<Theta>(\<lambda>n. log 2 (fact n))" by (simp add: log_def)
  also have "(\<lambda>n. log 2 (fact n)) \<in> O(\<lambda>n. count_wc_queries (Rs n) (sorter n))"
  proof (intro bigoI[where c = 1] always_eventually allI, goal_cases)
    case (1 n)
    have "norm (log 2 (fact n)) = log 2 (fact (length [0..<n]))" by simp
    also from sorter[of n] have "\<dots> \<le> real (count_wc_queries (Rs n) (sorter n))"
      using count_queries_ge[of "[0..<n]" "sorter n"] by (auto simp: Rs_def atLeast0LessThan)
    also have "\<dots> = 1 * norm \<dots>" by simp
    finally show ?case by simp
  qed
  finally show ?thesis by (simp add: bigomega_iff_bigo)
qed

end


(* exercise 3.11 *)
theory ASMReg
  imports
    AExp "~~/src/HOL/Library/Code_Target_Nat"
begin

section "Register Machine and Compilation"
subsection "Register Machine"

  (* A register identifier is a natural number. I.e. the registers are numbered 0, 1, ...  *)
type_synonym reg = nat

datatype instr =
  LDI int reg | (* store integer in register *)
  LD vname reg | (* take variable from current state, store in register *)
  ADD reg reg (* add right register to left, store in left *)

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
  "exec1 (LDI ii ir) _ registers = (registers (ir := ii))" |
  "exec1 (LD iv ir) state registers = (registers (ir := (state iv)))" |
  "exec1 (ADD r\<^sub>d r\<^sub>s) _ registers = (registers (r\<^sub>d := (registers r\<^sub>d) + (registers r\<^sub>s)))"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
  "exec [] _ registers = registers" |
  "exec (i#is) state registers = exec is state (exec1 i state registers)"

lemma exec_append:"exec (l1 @ l2) s rs = exec l2 s (exec l1 s rs)"
  (* rs MUST be arbitrary. This strengthens the induction hypothesis: the register
    file in the IH may be different than the register file in the thesis.
    This is necessary, because the inductive step adds another instruction, which will cause the
    register file to change when executed. That is, the register file in the inductive step will be
    different than the register file in the IH, because of the inductive step. *)
  apply(induction l1 arbitrary: rs)
   apply(simp_all)
  done

subsection "Compilation"

  (* The compiler takes an arithmetic expression a and a register r and produces a list of
instructions whose execution places the value of a into r. The registers > r should be used in a
stack-like fashion for intermediate results, the ones < r should be left alone. *)
fun compile :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "compile (N n) r\<^sub>d = [LDI n r\<^sub>d]" |
  "compile (V v) r\<^sub>d = [LD v r\<^sub>d]" |
  "compile (Plus e\<^sub>1 e\<^sub>2) r\<^sub>d = (let
    left = compile e\<^sub>1 r\<^sub>d;
    right = compile e\<^sub>2 (r\<^sub>d + 1)
  in left @ right @ [ADD r\<^sub>d (r\<^sub>d + 1)])"

value "compile (Plus (N 9) (N 10)) 0"
value "exec (compile (Plus (N 9) (N 10)) 1) <> <> 1"

lemma lesser_registers_unchanged:
  "reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y < reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t \<Longrightarrow>
    (exec (compile exp reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t) st rs) reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y = rs reg\<^sub>q\<^sub>u\<^sub>e\<^sub>r\<^sub>y"
  (* arbitrary reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t is required because it changes when compiling ADD
    arbitrary rs is required because it changes when executing *)
  apply(induction exp arbitrary: rs reg\<^sub>d\<^sub>e\<^sub>s\<^sub>t)
    apply(simp_all)
  using exec_append by simp

theorem compile_is_correct: "exec (compile expr reg_dest) state rs reg_dest = aval expr state"
  (* reg_dest is arbitrary because it changes during compile ADD
    rs is arbitrary because it changes during exec*)
  apply(induction expr arbitrary: reg_dest rs)
    apply(simp_all)
  using exec_append lesser_registers_unchanged by simp

end


(*
  File: Indexed_PQueue.thy
  Author: Bohua Zhan
*)

section \<open>Indexed priority queues\<close>

theory Indexed_PQueue
  imports Arrays_Ex Mapping_Str
begin

text \<open>
  Verification of indexed priority queue: functional part. The data
  structure is also verified by Lammich in
  \<^cite>\<open>"Refine_Imperative_HOL-AFP"\<close>.
\<close>

subsection \<open>Successor functions, eq-pred predicate\<close>

fun s1 :: "nat \<Rightarrow> nat" where "s1 m = 2 * m + 1"
fun s2 :: "nat \<Rightarrow> nat" where "s2 m = 2 * m + 2"

lemma s_inj [forward]:
  "s1 m = s1 m' \<Longrightarrow> m = m'" "s2 m = s2 m' \<Longrightarrow> m = m'" by auto
lemma s_neq [resolve]:
  "s1 m \<noteq> s2 m'" "s1 m > m" "s2 m > m" "s2 m > s1 m" using s1.simps s2.simps by presburger+
setup \<open>add_forward_prfstep_cond @{thm s_neq(2)} [with_term "s1 ?m"]\<close>
setup \<open>add_forward_prfstep_cond @{thm s_neq(3)} [with_term "s2 ?m"]\<close>
setup \<open>add_forward_prfstep_cond @{thm s_neq(4)} [with_term "s2 ?m", with_term "s1 ?m"]\<close>

inductive eq_pred :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "eq_pred n n"
| "eq_pred n m \<Longrightarrow> eq_pred n (s1 m)"
| "eq_pred n m \<Longrightarrow> eq_pred n (s2 m)"
setup \<open>add_case_induct_rule @{thm eq_pred.cases}\<close>
setup \<open>add_prop_induct_rule @{thm eq_pred.induct}\<close>
setup \<open>add_resolve_prfstep @{thm eq_pred.intros(1)}\<close>
setup \<open>fold add_backward_prfstep @{thms eq_pred.intros(2,3)}\<close>

lemma eq_pred_parent1 [forward]:
  "eq_pred i (s1 k) \<Longrightarrow> i \<noteq> s1 k \<Longrightarrow> eq_pred i k"
@proof @let "v = s1 k" @prop_induct "eq_pred i v" @qed

lemma eq_pred_parent2 [forward]:
  "eq_pred i (s2 k) \<Longrightarrow> i \<noteq> s2 k \<Longrightarrow> eq_pred i k"
@proof @let "v = s2 k" @prop_induct "eq_pred i v" @qed

lemma eq_pred_cases:
  "eq_pred i j \<Longrightarrow> eq_pred (s1 i) j \<or> eq_pred (s2 i) j \<or> j = i \<or> j = s1 i \<or> j = s2 i"
@proof @prop_induct "eq_pred i j" @qed
setup \<open>add_forward_prfstep_cond @{thm eq_pred_cases} [with_cond "?i \<noteq> s1 ?k", with_cond "?i \<noteq> s2 ?k"]\<close>

lemma eq_pred_le [forward]: "eq_pred i j \<Longrightarrow> i \<le> j"
@proof @prop_induct "eq_pred i j" @qed

subsection \<open>Heap property\<close>

text \<open>The corresponding tree is a heap\<close>
definition is_heap :: "('a \<times> 'b::linorder) list \<Rightarrow> bool" where [rewrite]:
  "is_heap xs = (\<forall>i j. eq_pred i j \<longrightarrow> j < length xs \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

lemma is_heapD:
  "is_heap xs \<Longrightarrow> j < length xs \<Longrightarrow> eq_pred i j \<Longrightarrow> snd (xs ! i) \<le> snd (xs ! j)" by auto2
setup \<open>add_forward_prfstep_cond @{thm is_heapD} [with_term "?xs ! ?j"]\<close>
setup \<open>del_prfstep_thm_eqforward @{thm is_heap_def}\<close>

subsection \<open>Bubble-down\<close>

text \<open>The corresponding tree is a heap, except k is not necessarily smaller than its descendents.\<close>
definition is_heap_partial1 :: "('a \<times> 'b::linorder) list \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "is_heap_partial1 xs k = (\<forall>i j. eq_pred i j \<longrightarrow> i \<noteq> k \<longrightarrow> j < length xs \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

text \<open>Two cases of switching with s1 k.\<close>
lemma bubble_down1:
  "s1 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! k) > snd (xs ! s1 k) \<Longrightarrow>
   snd (xs ! s1 k) \<le> snd (xs ! s2 k) \<Longrightarrow> is_heap_partial1 (list_swap xs k (s1 k)) (s1 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down1} [with_term "list_swap ?xs ?k (s1 ?k)"]\<close>

lemma bubble_down2:
  "s1 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! k) > snd (xs ! s1 k) \<Longrightarrow>
   s2 k \<ge> length xs \<Longrightarrow> is_heap_partial1 (list_swap xs k (s1 k)) (s1 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down2} [with_term "list_swap ?xs ?k (s1 ?k)"]\<close>

text \<open>One case of switching with s2 k.\<close>
lemma bubble_down3:
  "s2 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! s1 k) > snd (xs ! s2 k) \<Longrightarrow>
   snd (xs ! k) > snd (xs ! s2 k) \<Longrightarrow> xs' = list_swap xs k (s2 k) \<Longrightarrow> is_heap_partial1 xs' (s2 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down3} [with_term "?xs'"]\<close>

subsection \<open>Bubble-up\<close>

fun par :: "nat \<Rightarrow> nat" where
  "par m = (m - 1) div 2"
setup \<open>register_wellform_data ("par m", ["m \<noteq> 0"])\<close>

lemma ps_inverse [rewrite]: "par (s1 k) = k" "par (s2 k) = k" by simp+

lemma p_basic: "m \<noteq> 0 \<Longrightarrow> par m < m" by auto
setup \<open>add_forward_prfstep_cond @{thm p_basic} [with_term "par ?m"]\<close>

lemma p_cases: "m \<noteq> 0 \<Longrightarrow> m = s1 (par m) \<or> m = s2 (par m)" by auto
setup \<open>add_forward_prfstep_cond @{thm p_cases} [with_term "par ?m"]\<close>

lemma eq_pred_p_next:
  "i \<noteq> 0 \<Longrightarrow> eq_pred i j \<Longrightarrow> eq_pred (par i) j"
@proof @prop_induct "eq_pred i j" @qed
setup \<open>add_forward_prfstep_cond @{thm eq_pred_p_next} [with_term "par ?i"]\<close>

lemma heap_implies_hd_min [resolve]:
  "is_heap xs \<Longrightarrow> i < length xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> snd (hd xs) \<le> snd (xs ! i)"
@proof
  @strong_induct i
  @case "i = 0" @apply_induct_hyp "par i"
  @have "eq_pred (par i) i"
@qed

text \<open>The corresponding tree is a heap, except k is not necessarily greater than its ancestors.\<close>
definition is_heap_partial2 :: "('a \<times> 'b::linorder) list \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "is_heap_partial2 xs k = (\<forall>i j. eq_pred i j \<longrightarrow> j < length xs \<longrightarrow> j \<noteq> k \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

lemma bubble_up1 [forward]:
  "k < length xs \<Longrightarrow> is_heap_partial2 xs k \<Longrightarrow> snd (xs ! k) < snd (xs ! par k) \<Longrightarrow> k \<noteq> 0 \<Longrightarrow>
   is_heap_partial2 (list_swap xs k (par k)) (par k)" by auto2

lemma bubble_up2 [forward]:
  "k < length xs \<Longrightarrow> is_heap_partial2 xs k \<Longrightarrow> snd (xs ! k) \<ge> snd (xs ! par k) \<Longrightarrow> k \<noteq> 0 \<Longrightarrow>
   is_heap xs" by auto2
setup \<open>del_prfstep_thm @{thm p_cases}\<close>

subsection \<open>Indexed priority queue\<close>

type_synonym 'a idx_pqueue = "(nat \<times> 'a) list \<times> nat option list"

fun index_of_pqueue :: "'a idx_pqueue \<Rightarrow> bool" where
  "index_of_pqueue (xs, m) = (
    (\<forall>i<length xs. fst (xs ! i) < length m \<and> m ! (fst (xs ! i)) = Some i) \<and>
    (\<forall>i. \<forall>k<length m. m ! k = Some i \<longrightarrow> i < length xs \<and> fst (xs ! i) = k))"
setup \<open>add_rewrite_rule @{thm index_of_pqueue.simps}\<close>

lemma index_of_pqueueD1:
  "i < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   fst (xs ! i) < length m \<and> m ! (fst (xs ! i)) = Some i" by auto2
setup \<open>add_forward_prfstep_cond @{thm index_of_pqueueD1} [with_term "?xs ! ?i"]\<close>

lemma index_of_pqueueD2 [forward]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   m ! k = Some i \<Longrightarrow> i < length xs \<and> fst (xs ! i) = k" by auto2

lemma index_of_pqueueD3 [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> p \<in> set xs \<Longrightarrow> fst p < length m"
@proof @obtain i where "i < length xs" "xs ! i = p" @qed
setup \<open>del_prfstep_thm_eqforward @{thm index_of_pqueue.simps}\<close>

lemma has_index_unique_key [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> unique_keys_set (set xs)"
@proof
  @have "\<forall>a x y. (a, x) \<in> set xs \<longrightarrow> (a, y) \<in> set xs \<longrightarrow> x = y" @with
    @obtain i where "i < length xs" "xs ! i = (a, x)"
    @obtain j where "j < length xs" "xs ! j = (a, y)"
  @end
@qed

lemma has_index_keys_of [rewrite]:
  "index_of_pqueue (xs, m) \<Longrightarrow> has_key_alist xs k \<longleftrightarrow> (k < length m \<and> m ! k \<noteq> None)"
@proof
  @case "has_key_alist xs k" @with
    @obtain v' where "(k, v') \<in> set xs"
    @obtain i where "i < length xs \<and> xs ! i = (k, v')"
  @end
@qed

lemma has_index_distinct [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> distinct xs"
@proof
  @have "\<forall>i<length xs. \<forall>j<length xs. i \<noteq> j \<longrightarrow> xs ! i \<noteq> xs ! j"
@qed

subsection \<open>Basic operations on indexed\_queue\<close>

fun idx_pqueue_swap_fun :: "(nat \<times> 'a) list \<times> nat option list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<times> nat option list" where
  "idx_pqueue_swap_fun (xs, m) i j = (
    list_swap xs i j, ((m [fst (xs ! i) := Some j]) [fst (xs ! j) := Some i]))"

lemma index_of_pqueue_swap [forward_arg]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   index_of_pqueue (idx_pqueue_swap_fun (xs, m) i j)"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

lemma fst_idx_pqueue_swap [rewrite]:
  "fst (idx_pqueue_swap_fun (xs, m) i j) = list_swap xs i j"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

lemma snd_idx_pqueue_swap [rewrite]:
  "length (snd (idx_pqueue_swap_fun (xs, m) i j)) = length m"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

fun idx_pqueue_push_fun :: "nat \<Rightarrow> 'a \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "idx_pqueue_push_fun k v (xs, m) = (xs @ [(k, v)], list_update m k (Some (length xs)))"

lemma idx_pqueue_push_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   r = idx_pqueue_push_fun k v (xs, m) \<Longrightarrow>
   index_of_pqueue r \<and> fst r = xs @ [(k, v)] \<and> length (snd r) = length m"
@proof @unfold "idx_pqueue_push_fun k v (xs, m)" @qed

fun idx_pqueue_pop_fun :: "'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "idx_pqueue_pop_fun (xs, m) = (butlast xs, list_update m (fst (last xs)) None)"

lemma idx_pqueue_pop_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> r = idx_pqueue_pop_fun (xs, m) \<Longrightarrow>
   index_of_pqueue r \<and> fst r = butlast xs \<and> length (snd r) = length m"
@proof
  @unfold "idx_pqueue_pop_fun (xs, m)"
  @have "length xs = length (butlast xs) + 1"
  @have "fst (xs ! length (butlast xs)) < length m"  (* TODO: remove? *)
@qed

subsection \<open>Bubble up and down\<close>

function idx_bubble_down_fun :: "'a::linorder idx_pqueue \<Rightarrow> nat \<Rightarrow> 'a idx_pqueue" where
  "idx_bubble_down_fun (xs, m) k = (
    if s2 k < length xs then
      if snd (xs ! s1 k) \<le> snd (xs ! s2 k) then
        if snd (xs ! k) > snd (xs ! s1 k) then
          idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s1 k)) (s1 k)
        else (xs, m)
      else
        if snd (xs ! k) > snd (xs ! s2 k) then
          idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s2 k)) (s2 k)
        else (xs, m)
    else if s1 k < length xs then
      if snd (xs ! k) > snd (xs ! s1 k) then
        idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s1 k)) (s1 k)
      else (xs, m)
    else (xs, m))"
  by pat_completeness auto
  termination by (relation "measure (\<lambda>((xs,_),k). (length xs - k))") (simp_all, auto2+)

lemma idx_bubble_down_fun_correct:
  "r = idx_bubble_down_fun x k \<Longrightarrow> is_heap_partial1 (fst x) k \<Longrightarrow>
   is_heap (fst r) \<and> mset (fst r) = mset (fst x) \<and> length (snd r) = length (snd x)"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed
setup \<open>add_forward_prfstep_cond @{thm idx_bubble_down_fun_correct} [with_term "?r"]\<close>

lemma idx_bubble_down_fun_correct2 [forward]:
  "index_of_pqueue x \<Longrightarrow> index_of_pqueue (idx_bubble_down_fun x k)"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed

fun idx_bubble_up_fun :: "'a::linorder idx_pqueue \<Rightarrow> nat \<Rightarrow> 'a idx_pqueue" where
  "idx_bubble_up_fun (xs, m) k = (
    if k = 0 then (xs, m)
    else if k < length xs then
      if snd (xs ! k) < snd (xs ! par k) then
        idx_bubble_up_fun (idx_pqueue_swap_fun (xs, m) k (par k)) (par k)
      else (xs, m)
    else (xs, m))"

lemma idx_bubble_up_fun_correct:
  "r = idx_bubble_up_fun x k \<Longrightarrow> is_heap_partial2 (fst x) k \<Longrightarrow>
   is_heap (fst r) \<and> mset (fst r) = mset (fst x) \<and> length (snd r) = length (snd x)"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed
setup \<open>add_forward_prfstep_cond @{thm idx_bubble_up_fun_correct} [with_term "?r"]\<close>

lemma idx_bubble_up_fun_correct2 [forward]:
  "index_of_pqueue x \<Longrightarrow> index_of_pqueue (idx_bubble_up_fun x k)"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed

subsection \<open>Main operations\<close>

fun delete_min_idx_pqueue_fun :: "'a::linorder idx_pqueue \<Rightarrow> (nat \<times> 'a) \<times> 'a idx_pqueue" where
  "delete_min_idx_pqueue_fun (xs, m) = (
    let (xs', m') = idx_pqueue_swap_fun (xs, m) 0 (length xs - 1);
        a'' = idx_pqueue_pop_fun (xs', m')
     in (last xs', idx_bubble_down_fun a'' 0))"

lemma delete_min_idx_pqueue_correct:
  "index_of_pqueue (xs, m) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> res = delete_min_idx_pqueue_fun (xs, m) \<Longrightarrow>
   index_of_pqueue (snd res)"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)" @qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_idx_pqueue_correct} [with_term "?res"]\<close>

lemma hd_last_swap_eval_last [rewrite]:
  "xs \<noteq> [] \<Longrightarrow> last (list_swap xs 0 (length xs - 1)) = hd xs"
@proof
  @let "xs' = list_swap xs 0 (length xs - 1)"
  @have "last xs' = xs' ! (length xs - 1)"
@qed

text \<open>Correctness of delete-min.\<close>
theorem delete_min_idx_pqueue_correct2:
  "is_heap xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> res = delete_min_idx_pqueue_fun (xs, m) \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   is_heap (fst (snd res)) \<and> fst res = hd xs \<and> length (snd (snd res)) = length m \<and>
   map_of_alist (fst (snd res)) = delete_map (fst (fst res)) (map_of_alist xs)"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)"
  @let "xs' = list_swap xs 0 (length xs - 1)"
  @have "is_heap_partial1 (butlast xs') 0"
@qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_idx_pqueue_correct2} [with_term "?res"]\<close>

fun insert_idx_pqueue_fun :: "nat \<Rightarrow> 'a::linorder \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "insert_idx_pqueue_fun k v x = (
    let x' = idx_pqueue_push_fun k v x in
      idx_bubble_up_fun x' (length (fst x') - 1))"

lemma insert_idx_pqueue_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   index_of_pqueue (insert_idx_pqueue_fun k v (xs, m))"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)" @qed

text \<open>Correctness of insertion.\<close>
theorem insert_idx_pqueue_correct2:
  "index_of_pqueue (xs, m) \<Longrightarrow> is_heap xs \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   r = insert_idx_pqueue_fun k v (xs, m) \<Longrightarrow>
   is_heap (fst r) \<and> length (snd r) = length m \<and>
   map_of_alist (fst r) = map_of_alist xs { k \<rightarrow> v }"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)"
  @have "is_heap_partial2 (xs @ [(k, v)]) (length xs)"
@qed
setup \<open>add_forward_prfstep_cond @{thm insert_idx_pqueue_correct2} [with_term "?r"]\<close>

fun update_idx_pqueue_fun :: "nat \<Rightarrow> 'a::linorder \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "update_idx_pqueue_fun k v (xs, m) = (
    if m ! k = None then
      insert_idx_pqueue_fun k v (xs, m)
    else let
      i = the (m ! k);
      xs' = list_update xs i (k, v)
    in
      if snd (xs ! i) \<le> v then idx_bubble_down_fun (xs', m) i
      else idx_bubble_up_fun (xs', m) i)"

lemma update_idx_pqueue_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow>
   index_of_pqueue (update_idx_pqueue_fun k v (xs, m))"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)"
  @let "i' = the (m ! k)"
  @let "xs' = list_update xs i' (k, v)"
  @case "m ! k = None"
  @have "index_of_pqueue (xs', m)"
@qed

text \<open>Correctness of update.\<close>
theorem update_idx_pqueue_correct2:
  "index_of_pqueue (xs, m) \<Longrightarrow> is_heap xs \<Longrightarrow> k < length m \<Longrightarrow>
   r = update_idx_pqueue_fun k v (xs, m) \<Longrightarrow>
   is_heap (fst r) \<and> length (snd r) = length m \<and>
   map_of_alist (fst r) = map_of_alist xs { k \<rightarrow> v }"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)"
  @let "i = the (m ! k)"
  @let "xs' = list_update xs i (k, v)"
  @have "xs' = fst (xs', m)" (* TODO: remove *)
  @case "m ! k = None"
  @case "snd (xs ! the (m ! k)) \<le> v" @with
    @have "is_heap_partial1 xs' i"
  @end
  @have "is_heap_partial2 xs' i"
@qed
setup \<open>add_forward_prfstep_cond @{thm update_idx_pqueue_correct2} [with_term "?r"]\<close>

end