(*  Title:      HOL/Library/Stirling.thy
    Author:     Amine Chaieb
    Author:     Florian Haftmann
    Author:     Lukas Bulwahn
    Author:     Manuel Eberl
*)

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

theory Stirling
imports Main
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsubsection \<open>Efficient code\<close>

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

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

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

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

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

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

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

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

end


theory Induccion
imports Main
begin

section {* Definiciones de la función inversa *}

text {* (inversa xs) es la inversa de xs. Por ejemplo,
     inversa [a,b,c] = [c,b,a]
*}
fun inversa :: "'a list \<Rightarrow> 'a list" where
  "inversa []     = []"
| "inversa (x#xs) = inversa xs @ [x]"

value "inversa [a,b,c]"
lemma "inversa [a,b,c] = [c,b,a]" by simp

text {* (inversaIaux xs) es la inversa de xs calculada de manera
  iterativa. Por ejemplo,
     inversaIaux [a,b,c] = [c,b,a]
*}
fun inversaIaux :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "inversaIaux [] ys     = ys"
| "inversaIaux (x#xs) ys = inversaIaux xs (x#ys)"

definition inversaI :: "'a list \<Rightarrow> 'a list"
where
  "inversaI xs = inversaIaux xs []"

value "inversaI [a,b,c]"
lemma "inversaI [a,b,c] = [c,b,a]" by (simp add: inversaI_def)

section {* Equivalencia de las definiciones de inversa *}

text {* El objetivo de esta sección es demostrar la equivalencia de las
  dos definiciones; es decir,
     equiv_inversa: "inversaI xs = inversa xs"

  A la vista de la definición de inversaI, se observa que la propiedad
  anterior es un corolario de
     equiv_inversa_aux: "inversaIaux xs [] = inversa xs"

  Vamos a demostrar equiv_inversa_aux usando heurísticas de inducción.
*}

text {* 1\<ordmasculine> intento de prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux_1:
  "inversaIaux xs [] = inversa xs"
apply (induction xs)
apply auto
oops

text {* Se observa que se queda sin demostrar el objetivo
     inversaIaux xs [] = inversa xs \<Longrightarrow>
     inversaIaux xs [a] = inversa xs @ [a]

  La causa es que el enunciado era demasiado específico al tener como
  segundo argumento la lista vacía. Lo generalizamos a
     equiv_inversa_aux_2: inversaIaux xs ys = inversa xs @ ys
*}

text {* 2\<ordmasculine> intento de prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux_2:
  "inversaIaux xs ys = inversa xs @ ys"
apply (induction xs)
apply auto
oops

text {* Se observa que se queda sin demostrar el objetivo
     inversaIaux xs ys = inversa xs @ ys \<Longrightarrow>
     inversaIaux xs (a # ys) = inversa xs @ a # ys

  La causa es que aunque el segundo argumento es la variable ys, no se
  ha tenido en cuenta que su valor varía. Por tanto, hay que declararla
  como arbitraria.
*}

text {* Prueba de equiv_inversa_aux *}
lemma equiv_inversa_aux:
  "inversaIaux xs ys = inversa xs @ ys"
apply (induction xs arbitrary: ys)
apply auto
done

text {* Prueba de equiv_inversa *}
corollary equiv_inversa:
  "inversaI xs = inversa xs"
apply (simp add: inversaI_def equiv_inversa_aux)
done

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: FSet_Extra.thy                                                       *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)

section {* Finite Sets: extra functions and properties *}

theory FSet_Extra
imports
  "HOL-Library.FSet"
  "HOL-Library.Countable_Set_Type"
begin

setup_lifting type_definition_fset

notation fempty ("\<lbrace>\<rbrace>")
notation fset ("\<langle>_\<rangle>\<^sub>f")
notation fminus (infixl "-\<^sub>f" 65)

syntax
  "_FinFset" :: "args => 'a fset"    ("\<lbrace>(_)\<rbrace>")

translations
  "\<lbrace>x, xs\<rbrace>" == "CONST finsert x \<lbrace>xs\<rbrace>"
  "\<lbrace>x\<rbrace>" == "CONST finsert x \<lbrace>\<rbrace>"

term "fBall"

syntax
  "_fBall" :: "pttrn => 'a fset => bool => bool" ("(3\<forall> _|\<in>|_./ _)" [0, 0, 10] 10)
  "_fBex"  :: "pttrn => 'a fset => bool => bool" ("(3\<exists> _|\<in>|_./ _)" [0, 0, 10] 10)

translations
  "\<forall> x|\<in>|A. P" == "CONST fBall A (%x. P)"
  "\<exists> x|\<in>|A. P" == "CONST fBex A (%x. P)"

definition FUnion :: "'a fset fset \<Rightarrow> 'a fset" ("\<Union>\<^sub>f_" [90] 90) where
"FUnion xs = Abs_fset (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"

definition FInter :: "'a fset fset \<Rightarrow> 'a fset" ("\<Inter>\<^sub>f_" [90] 90) where
"FInter xs = Abs_fset (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"

text \<open> Finite power set \<close>

definition FinPow :: "'a fset \<Rightarrow> 'a fset fset" where
"FinPow xs = Abs_fset (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)"

text \<open> Set of all finite subsets of a set \<close>

definition Fow :: "'a set \<Rightarrow> 'a fset set" where
"Fow A = {x. \<langle>x\<rangle>\<^sub>f \<subseteq> A}"

declare Abs_fset_inverse [simp]

lemma fset_intro:
  "fset x = fset y \<Longrightarrow> x = y"
  by (simp add:fset_inject)

lemma fset_elim:
  "\<lbrakk> x = y; fset x = fset y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto)

lemma fmember_intro:
  "\<lbrakk> x \<in> fset(xs) \<rbrakk> \<Longrightarrow> x |\<in>| xs"
  by (metis fmember.rep_eq)

lemma fmember_elim:
  "\<lbrakk> x |\<in>| xs; x \<in> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis fmember.rep_eq)

lemma fnmember_intro [intro]:
  "\<lbrakk> x \<notin> fset(xs) \<rbrakk> \<Longrightarrow> x |\<notin>| xs"
  by (metis fmember.rep_eq)

lemma fnmember_elim [elim]:
  "\<lbrakk> x |\<notin>| xs; x \<notin> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis fmember.rep_eq)

lemma fsubset_intro [intro]:
  "\<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> xs |\<subseteq>| ys"
  by (metis less_eq_fset.rep_eq)

lemma fsubset_elim [elim]:
  "\<lbrakk> xs |\<subseteq>| ys; \<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis less_eq_fset.rep_eq)

lemma fBall_intro [intro]:
  "Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> fBall A P"
  by (metis (poly_guards_query) fBallI fmember.rep_eq)

lemma fBall_elim [elim]:
  "\<lbrakk> fBall A P; Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (metis fBallE fmember.rep_eq)

lift_definition finset :: "'a list \<Rightarrow> 'a fset" is set ..

context linorder
begin

lemma sorted_list_of_set_inj:
  "\<lbrakk> finite xs; finite ys; sorted_list_of_set xs = sorted_list_of_set ys \<rbrakk>
   \<Longrightarrow> xs = ys"
  apply (simp add:sorted_list_of_set_def)
  apply (induct xs rule:finite_induct)
   apply (induct ys rule:finite_induct)
    apply (simp_all)
   apply (metis finite.insertI insert_not_empty sorted_list_of_set_def sorted_list_of_set_empty sorted_list_of_set_eq_Nil_iff)
  apply (metis finite.insertI finite_list set_remdups set_sort sorted_list_of_set_def sorted_list_of_set_sort_remdups)
  done

definition flist :: "'a fset \<Rightarrow> 'a list" where
"flist xs = sorted_list_of_set (fset xs)"

lemma flist_inj: "inj flist"
  apply (simp add:flist_def inj_on_def)
  apply (clarify)
  apply (rename_tac x y)
  apply (subgoal_tac "fset x = fset y")
   apply (simp add:fset_inject)
  apply (rule sorted_list_of_set_inj, simp_all)
  done

lemma flist_props [simp]:
  "sorted (flist xs)"
  "distinct (flist xs)"
  by (simp_all add:flist_def)

lemma flist_empty [simp]:
  "flist \<lbrace>\<rbrace> = []"
  by (simp add:flist_def)

lemma flist_inv [simp]: "finset (flist xs) = xs"
  by (simp add:finset_def flist_def fset_inverse)

lemma flist_set [simp]: "set (flist xs) = fset xs"
  by (simp add:finset_def flist_def fset_inverse)

lemma fset_inv [simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> flist (finset xs) = xs"
  apply (simp add:finset_def flist_def fset_inverse)
  apply (metis local.sorted_list_of_set_sort_remdups local.sorted_sort_id remdups_id_iff_distinct)
  done

lemma fcard_flist:
  "fcard xs = length (flist xs)"
  apply (simp add:fcard_def)
  apply (fold flist_set)
  apply (unfold distinct_card[OF flist_props(2)])
  apply (rule refl)
  done

lemma flist_nth:
  "i < fcard vs \<Longrightarrow> flist vs ! i |\<in>| vs"
  apply (simp add: fmember_def flist_def fcard_def)
  apply (metis fcard.rep_eq fcard_flist finset.rep_eq flist_def flist_inv nth_mem)
  done

definition fmax :: "'a fset \<Rightarrow> 'a" where
"fmax xs = (if (xs = \<lbrace>\<rbrace>) then undefined else last (flist xs))"

end

definition flists :: "'a fset \<Rightarrow> 'a list set" where
"flists A = {xs. distinct xs \<and> finset xs = A}"

lemma flists_nonempty: "\<exists> xs. xs \<in> flists A"
  apply (simp add: flists_def)
  apply (metis Abs_fset_cases Abs_fset_inverse finite_distinct_list finite_fset finset.rep_eq)
  done

lemma flists_elem_uniq: "\<lbrakk> x \<in> flists A; x \<in> flists B \<rbrakk> \<Longrightarrow> A = B"
  by (simp add: flists_def)

definition flist_arb :: "'a fset \<Rightarrow> 'a list" where
"flist_arb A = (SOME xs. xs \<in> flists A)"

lemma flist_arb_distinct [simp]: "distinct (flist_arb A)"
  by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)

lemma flist_arb_inv [simp]: "finset (flist_arb A) = A"
  by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)

lemma flist_arb_inj:
  "inj flist_arb"
  by (metis flist_arb_inv injI)

lemma flist_arb_lists: "flist_arb ` Fow A \<subseteq> lists A"
  apply (auto)
  using Fow_def finset.rep_eq apply fastforce
  done

lemma countable_Fow:
  fixes A :: "'a set"
  assumes "countable A"
  shows "countable (Fow A)"
proof -
  from assms obtain to_nat_list :: "'a list \<Rightarrow> nat" where "inj_on to_nat_list (lists A)"
    by blast
  thus ?thesis
    apply (simp add: countable_def)
    apply (rule_tac x="to_nat_list \<circ> flist_arb" in exI)
    apply (rule comp_inj_on)
     apply (metis flist_arb_inv inj_on_def)
    apply (simp add: flist_arb_lists subset_inj_on)
    done
qed

definition flub :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"flub A t = (if (\<forall> a\<in>A. a |\<subseteq>| t) then Abs_fset (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else t)"

lemma finite_Union_subsets:
  "\<lbrakk> \<forall> a \<in> A. a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>A)"
  by (metis Sup_le_iff finite_subset)

lemma finite_UN_subsets:
  "\<lbrakk> \<forall> a \<in> A. B a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
  by (metis UN_subset_iff finite_subset)

lemma flub_rep_eq:
  "\<langle>flub A t\<rangle>\<^sub>f = (if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f)"
  apply (subgoal_tac "(if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f) \<in> {x. finite x}")
   apply (auto simp add:flub_def)
  apply (rule finite_UN_subsets[of _ _ "\<langle>t\<rangle>\<^sub>f"])
   apply (auto)
  done

definition fglb :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"fglb A t = (if (A = {}) then t else Abs_fset (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"

lemma fglb_rep_eq:
  "\<langle>fglb A t\<rangle>\<^sub>f = (if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"
  apply (subgoal_tac "(if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f)) \<in> {x. finite x}")
   apply (metis Abs_fset_inverse fglb_def)
  apply (auto)
  apply (metis finite_INT finite_fset)
  done

lemma FinPow_rep_eq [simp]:
  "fset (FinPow xs) = {ys. ys |\<subseteq>| xs}"
  apply (subgoal_tac "finite (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)")
   apply (auto simp add: fmember_def FinPow_def)
   apply (rename_tac x' y')
   apply (subgoal_tac "finite x'")
    apply (auto)
   apply (metis finite_fset finite_subset)
  apply (metis (full_types) Pow_iff fset_inverse imageI less_eq_fset.rep_eq)
  done

lemma FUnion_rep_eq [simp]:
  "\<langle>\<Union>\<^sub>f xs\<rangle>\<^sub>f = (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
  by (simp add:FUnion_def)

lemma FInter_rep_eq [simp]:
  "xs \<noteq> \<lbrace>\<rbrace> \<Longrightarrow> \<langle>\<Inter>\<^sub>f xs\<rangle>\<^sub>f = (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
  apply (simp add:FInter_def)
  apply (subgoal_tac "finite (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)")
   apply (simp)
  apply (metis (poly_guards_query) bot_fset.rep_eq fglb_rep_eq finite_fset fset_inverse)
  done

lemma FUnion_empty [simp]:
  "\<Union>\<^sub>f \<lbrace>\<rbrace> = \<lbrace>\<rbrace>"
  by (auto simp add:FUnion_def fmember_def)

lemma FinPow_member [simp]:
  "xs |\<in>| FinPow xs"
  by (auto simp add:fmember_def)

lemma FUnion_FinPow [simp]:
  "\<Union>\<^sub>f (FinPow x) = x"
  by (auto simp add:fmember_def less_eq_fset_def)

lemma Fow_mem [iff]: "x \<in> Fow A \<longleftrightarrow> \<langle>x\<rangle>\<^sub>f \<subseteq> A"
  by (auto simp add:Fow_def)

lemma Fow_UNIV [simp]: "Fow UNIV = UNIV"
  by (simp add:Fow_def)

lift_definition FMax :: "('a::linorder) fset \<Rightarrow> 'a" is "Max" .

end


theory boolean_algebra_functional
  imports boolean_algebra
begin

subsection \<open>Algebraic connectives on set-valued functions\<close>

(**Functions with sets in their codomain will be called here 'set-valued functions'.
  We conveniently define some (2nd-order) Boolean operations on them.*)

(**The 'meet' and 'join' of two set-valued functions: *)
definition svfun_meet::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>)" (infixr "\<^bold>\<sqinter>" 62)
  where "\<phi> \<^bold>\<sqinter> \<psi> \<equiv> \<lambda>x. (\<phi> x) \<^bold>\<and> (\<psi> x)"
definition svfun_join::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>)" (infixr "\<^bold>\<squnion>" 61)
  where "\<phi> \<^bold>\<squnion> \<psi> \<equiv> \<lambda>x. (\<phi> x) \<^bold>\<or> (\<psi> x)"
(**analogously, we can define an 'implication' and a 'complement'*)
definition svfun_impl::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>)" (infixr "\<^bold>\<sqsupset>" 61)
  where "\<psi> \<^bold>\<sqsupset> \<phi> \<equiv> \<lambda>x. (\<psi> x) \<^bold>\<rightarrow> (\<phi> x)"
definition svfun_compl::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>)" ("(_\<^sup>c)")
  where "\<phi>\<^sup>c \<equiv> \<lambda>x. \<^bold>\<midarrow>(\<phi> x)"
(**There are two natural 0-ary connectives (aka. constants) *)
definition svfun_top::"'i \<Rightarrow> 'w \<sigma>" ("\<^bold>\<top>''")
  where "\<^bold>\<top>' \<equiv> \<lambda>x. \<^bold>\<top>"
definition svfun_bot::"'i \<Rightarrow> 'w \<sigma>" ("\<^bold>\<bottom>''")
  where "\<^bold>\<bottom>' \<equiv> \<lambda>x. \<^bold>\<bottom>"

named_theorems conn2 (*to group together definitions for 2nd-order algebraic connectives*)
declare svfun_meet_def[conn2] svfun_join_def[conn2] svfun_impl_def[conn2]
        svfun_compl_def[conn2] svfun_top_def[conn2] svfun_bot_def[conn2]

(**And, of course, set-valued functions are naturally ordered in the expected way*)
definition svfun_sub::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" (infixr "\<sqsubseteq>" 55)
  where "\<psi> \<sqsubseteq> \<phi> \<equiv> \<forall>x. (\<psi> x) \<preceq> (\<phi> x)"
definition svfun_equ::"('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('i \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" (infixr "\<cong>" 55)
  where "\<psi> \<cong> \<phi> \<equiv> \<forall>x. (\<psi> x) \<approx> (\<phi> x)"

named_theorems order2 (*to group together definitions for 2nd-order algebraic connectives*)
declare svfun_sub_def[order2] svfun_equ_def[order2]

lemma svfun_sub_char: "(\<psi> \<sqsubseteq> \<phi>) = (\<psi> \<^bold>\<sqsupset> \<phi> \<cong> \<^bold>\<top>')" by (simp add: BA_impl svfun_equ_def svfun_impl_def svfun_sub_def svfun_top_def)
lemma svfun_equ_char: "(\<psi> \<cong> \<phi>) = (\<psi> \<sqsubseteq> \<phi> \<and> \<phi> \<sqsubseteq> \<psi>)" unfolding order2 setequ_char by blast
lemma svfun_equ_ext: "(\<psi> \<cong> \<phi>) = (\<psi> = \<phi>)" by (meson ext setequ_ext svfun_equ_def)

(**Clearly, set-valued functions form a Boolean algebra. We can prove some interesting relationships*)
lemma svfun_compl_char: "\<phi>\<^sup>c = (\<phi> \<^bold>\<sqsupset> \<^bold>\<bottom>')" unfolding conn conn2 by simp
lemma svfun_impl_char1: "(\<psi> \<^bold>\<sqsupset> \<phi>) = (\<psi>\<^sup>c \<^bold>\<squnion> \<phi>)" unfolding conn conn2 by simp
lemma svfun_impl_char2: "(\<psi> \<^bold>\<sqsupset> \<phi>) = (\<psi> \<^bold>\<sqinter> (\<phi>\<^sup>c))\<^sup>c" unfolding conn conn2 by simp
lemma svfun_deMorgan1: "(\<psi> \<^bold>\<sqinter> \<phi>)\<^sup>c = (\<psi>\<^sup>c) \<^bold>\<squnion> (\<phi>\<^sup>c)" unfolding conn conn2 by simp
lemma svfun_deMorgan2: "(\<psi> \<^bold>\<squnion> \<phi>)\<^sup>c = (\<psi>\<^sup>c) \<^bold>\<sqinter> (\<phi>\<^sup>c)" unfolding conn conn2 by simp

subsection \<open>Further algebraic connectives on operators\<close>

(**Dual to set-valued functions we can have set-domain functions. For them we can define the 'dual-complement'*)
definition sdfun_dcompl::"('w \<sigma> \<Rightarrow> 'i) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'i)" ("(_\<^sup>-)")
  where "\<phi>\<^sup>- \<equiv> \<lambda>X. \<phi>(\<^bold>\<midarrow>X)"
lemma sdfun_dcompl_char: "\<phi>\<^sup>- = (\<lambda>X. \<exists>Y. (\<phi> Y) \<and> (X = \<^bold>\<midarrow>Y))" by (metis BA_dn setequ_ext sdfun_dcompl_def)

(**Operators are a particularly important kind of functions. They are both set-valued and set-domain.
Thus our algebra of operators inherits the connectives defined above plus some idiosyncratic ones. *)

(**We conveniently define the 'dual' of an operator*)
definition op_dual::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("(_\<^sup>d)")
  where "\<phi>\<^sup>d \<equiv> \<lambda>X. \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>X))"

(**The following two 0-ary connectives (i.e operator 'constants') exist already (but somehow implicitly).
  We just make them explicit by introducing some convenient notation.*)
definition id_op::"'w \<sigma> \<Rightarrow> 'w \<sigma>" ("\<^bold>e")
  where "\<^bold>e \<equiv> \<lambda>X. X" (*introduces notation to refer to 'identity' operator*)
definition compl_op::"'w \<sigma> \<Rightarrow> 'w \<sigma>" ("\<^bold>n")
  where "\<^bold>n \<equiv> \<lambda>X. \<^bold>\<midarrow>X" (*to refer to 'complement' operator*)

declare sdfun_dcompl_def[conn2] op_dual_def[conn2] id_op_def[conn2] compl_op_def[conn2]

(**We now prove some lemmas (some of them might help provers in their hard work).*)
lemma dual_compl_char1: "\<phi>\<^sup>- = (\<phi>\<^sup>d)\<^sup>c" unfolding conn2 conn order by simp
lemma dual_compl_char2: "\<phi>\<^sup>- = (\<phi>\<^sup>c)\<^sup>d" unfolding conn2 conn order by simp
lemma sfun_compl_invol: "\<phi>\<^sup>c\<^sup>c = \<phi>" unfolding conn2 conn order by simp
lemma dual_invol: "\<phi>\<^sup>d\<^sup>d = \<phi>" unfolding conn2 conn order by simp
lemma dualcompl_invol: "(\<phi>\<^sup>-)\<^sup>- = \<phi>" unfolding conn2 conn order by simp

lemma op_prop1: "\<^bold>e\<^sup>d = \<^bold>e" unfolding conn2 conn by simp
lemma op_prop2: "\<^bold>n\<^sup>d = \<^bold>n" unfolding conn2 conn by simp
lemma op_prop3: "\<^bold>e\<^sup>c = \<^bold>n" unfolding conn2 conn by simp
lemma op_prop4: "(\<phi> \<^bold>\<squnion> \<psi>)\<^sup>d = (\<phi>\<^sup>d) \<^bold>\<sqinter> (\<psi>\<^sup>d)" unfolding conn2 conn by simp
lemma op_prop5: "(\<phi> \<^bold>\<squnion> \<psi>)\<^sup>c = (\<phi>\<^sup>c) \<^bold>\<sqinter> (\<psi>\<^sup>c)" unfolding conn2 conn by simp
lemma op_prop6: "(\<phi> \<^bold>\<sqinter> \<psi>)\<^sup>d = (\<phi>\<^sup>d) \<^bold>\<squnion> (\<psi>\<^sup>d)" unfolding conn2 conn by simp
lemma op_prop7: "(\<phi> \<^bold>\<sqinter> \<psi>)\<^sup>c = (\<phi>\<^sup>c) \<^bold>\<squnion> (\<psi>\<^sup>c)" unfolding conn2 conn by simp
lemma op_prop8: "\<^bold>\<top>' = \<^bold>n \<^bold>\<squnion> \<^bold>e" unfolding conn2 conn by simp
lemma op_prop9: "\<^bold>\<bottom>' = \<^bold>n \<^bold>\<sqinter> \<^bold>e" unfolding conn2 conn by simp

(**The notion of a fixed-point is fundamental. We speak of sets being fixed-points of operators.
We define a function that given an operator returns the set of all its fixed-points.*)
definition fixpoints::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma>)\<sigma>" ("fp")
  where "fp \<phi> \<equiv> \<lambda>X. (\<phi> X) \<approx> X"
(**We can in fact 'operationalize' the function above thus obtaining a (2nd-order) 'fixed-point' connective*)
definition op_fixpoint::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("(_\<^sup>f\<^sup>p)")
(* definition op_fixpoint ("(_\<^sup>f\<^sup>p)")  *)
  where "\<phi>\<^sup>f\<^sup>p \<equiv> \<lambda>X. (\<phi> X) \<^bold>\<leftrightarrow> X"

declare fixpoints_def[conn2] op_fixpoint_def[conn2]

(**Interestingly, the fixed-point connective is definable in terms of the others*)
lemma op_fixpoint_char: "\<phi>\<^sup>f\<^sup>p = (\<phi> \<^bold>\<sqinter> \<^bold>e) \<^bold>\<squnion> (\<phi>\<^sup>c \<^bold>\<sqinter> \<^bold>n)" unfolding conn2 order conn by blast

(**Given an operator \<phi>: the fixed-points of \<phi>'s dual is the set of complements of \<phi>' fixed-points*)
lemma fp_dual: "fp \<phi>\<^sup>d = (fp \<phi>)\<^sup>-" unfolding order conn conn2 by blast
(**the fixed-points of \<phi>'s complement is the set of complements of the fixed-points of \<phi>'s dual-complement*)
lemma fp_compl: "fp \<phi>\<^sup>c = (fp (\<phi>\<^sup>-))\<^sup>-" by (simp add: dual_compl_char2 dualcompl_invol fp_dual)
(**the fixed-points of \<phi>'s dual-complement is the set of complements of the fixed-points of \<phi>'s complement*)
lemma fp_dcompl: "fp (\<phi>\<^sup>-) = (fp \<phi>\<^sup>c)\<^sup>-" by (simp add: dualcompl_invol fp_compl)

(**The fixed-points function and the fixed-point connective are essentially related.*)
lemma fp_rel: "fp \<phi> A \<longleftrightarrow> (\<phi>\<^sup>f\<^sup>p A) \<approx> \<^bold>\<top>" unfolding conn2 order conn by simp
lemma fp_d_rel:  "fp \<phi>\<^sup>d A \<longleftrightarrow> \<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>A) \<approx> \<^bold>\<top>" unfolding conn2 order conn by blast
lemma fp_c_rel: "fp \<phi>\<^sup>c A \<longleftrightarrow> \<phi>\<^sup>f\<^sup>p A \<approx> \<^bold>\<bottom>" unfolding conn2 order conn by blast
lemma fp_dc_rel: "fp (\<phi>\<^sup>-) A \<longleftrightarrow> \<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>A) \<approx> \<^bold>\<bottom>" unfolding conn2 order conn by simp

(**The fixed-point operation is involutive*)
lemma ofp_invol: "(\<phi>\<^sup>f\<^sup>p)\<^sup>f\<^sup>p = \<phi>" unfolding conn2 order conn by blast
(**and commutes the dual with the dual-complement operations*)
lemma ofp_comm_dc1: "(\<phi>\<^sup>d)\<^sup>f\<^sup>p = (\<phi>\<^sup>f\<^sup>p)\<^sup>-" unfolding conn2 order conn by blast
lemma ofp_comm_dc2:"(\<phi>\<^sup>-)\<^sup>f\<^sup>p = (\<phi>\<^sup>f\<^sup>p)\<^sup>d" unfolding conn2 order conn by simp

(**The fixed-point operation commutes with the complement*)
lemma ofp_comm_compl: "(\<phi>\<^sup>c)\<^sup>f\<^sup>p = (\<phi>\<^sup>f\<^sup>p)\<^sup>c" unfolding conn2 order conn by blast
(**The above motivates the following alternative definition for a 'complemented-fixed-point' operation*)
lemma ofp_fixpoint_compl_def: "\<phi>\<^sup>f\<^sup>p\<^sup>c = (\<lambda>X. (\<phi> X) \<^bold>\<triangle> X)" unfolding conn2 conn by simp
(**Analogously, the complemented fixed-point connective is also definable in terms of the others*)
lemma op_fixpoint_compl_char: "\<phi>\<^sup>f\<^sup>p\<^sup>c = (\<phi> \<^bold>\<squnion> \<^bold>e) \<^bold>\<sqinter> (\<phi>\<^sup>c \<^bold>\<squnion> \<^bold>n)" unfolding conn2 conn by blast

(**In fact, function composition can be seen as an additional binary connective for operators.
  We show below some interesting relationships that hold: *)
lemma op_prop10: "\<phi> = (\<^bold>e \<circ> \<phi>)" unfolding conn2 fun_comp_def by simp
lemma op_prop11: "\<phi> = (\<phi> \<circ> \<^bold>e)" unfolding conn2 fun_comp_def by simp
lemma op_prop12: "\<^bold>e = (\<^bold>n \<circ> \<^bold>n)" unfolding conn2 conn fun_comp_def by simp
lemma op_prop13: "\<phi>\<^sup>c = (\<^bold>n \<circ> \<phi>)" unfolding conn2 fun_comp_def by simp
lemma op_prop14: "\<phi>\<^sup>- = (\<phi> \<circ> \<^bold>n)" unfolding conn2 fun_comp_def by simp
lemma op_prop15: "\<phi>\<^sup>d = (\<^bold>n \<circ> \<phi> \<circ> \<^bold>n)" unfolding conn2 fun_comp_def by simp

(**There are also some useful properties regarding the images of operators*)
lemma im_prop1: "\<lbrakk>\<phi> D\<rbrakk>\<^sup>-  = \<lbrakk>\<phi>\<^sup>d D\<^sup>-\<rbrakk>" unfolding image_def op_dual_def sdfun_dcompl_def by (metis BA_dn setequ_ext)
lemma im_prop2: "\<lbrakk>\<phi>\<^sup>c D\<rbrakk>\<^sup>- = \<lbrakk>\<phi> D\<rbrakk>" unfolding image_def svfun_compl_def sdfun_dcompl_def by (metis BA_dn setequ_ext)
lemma im_prop3: "\<lbrakk>\<phi>\<^sup>d D\<rbrakk>\<^sup>- = \<lbrakk>\<phi> D\<^sup>-\<rbrakk>" unfolding image_def op_dual_def sdfun_dcompl_def by (metis BA_dn setequ_ext)
lemma im_prop4: "\<lbrakk>\<phi>\<^sup>- D\<rbrakk>\<^sup>- = \<lbrakk>\<phi>\<^sup>d D\<rbrakk>" unfolding image_def op_dual_def sdfun_dcompl_def by (metis BA_dn setequ_ext)
lemma im_prop5: "\<lbrakk>\<phi>\<^sup>c D\<^sup>-\<rbrakk>  = \<lbrakk>\<phi>\<^sup>- D\<rbrakk>\<^sup>-" unfolding image_def svfun_compl_def sdfun_dcompl_def by (metis (no_types, opaque_lifting) BA_dn setequ_ext)
lemma im_prop6: "\<lbrakk>\<phi>\<^sup>- D\<^sup>-\<rbrakk>  = \<lbrakk>\<phi> D\<rbrakk>" unfolding image_def sdfun_dcompl_def by (metis BA_dn setequ_ext)

(**Observe that all results obtained by assuming fixed-point predicates extend to their associated operators.*)
lemma "\<phi>\<^sup>f\<^sup>p(A) \<^bold>\<and> \<Gamma>(A) \<preceq> \<Delta>(A) \<longrightarrow> (fp \<phi>)(A) \<longrightarrow> \<Gamma>(A) \<preceq> \<Delta>(A)"
  by (simp add: fp_rel meet_def setequ_ext subset_def top_def)
lemma "\<phi>\<^sup>f\<^sup>p(A) \<^bold>\<and> \<phi>\<^sup>f\<^sup>p(B) \<^bold>\<and> (\<Gamma> A B) \<preceq> (\<Delta> A B) \<longrightarrow> (fp \<phi>)(A) \<and> (fp \<phi>)(B) \<longrightarrow> (\<Gamma> A B) \<preceq> (\<Delta> A B)"
  by (simp add: fp_rel meet_def setequ_ext subset_def top_def)

end


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

section \<open>Dijkstra's algorithm for shortest paths\<close>

theory Dijkstra
  imports Mapping_Str Arrays_Ex
begin

text \<open>
  Verification of Dijkstra's algorithm: function part.

  The algorithm is also verified by Nordhoff and Lammich in
  \<^cite>\<open>"Dijkstra_Shortest_Path-AFP"\<close>.
\<close>

subsection \<open>Graphs\<close>

datatype graph = Graph "nat list list"

fun size :: "graph \<Rightarrow> nat" where
  "size (Graph G) = length G"

fun weight :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "weight (Graph G) m n = (G ! m) ! n"

fun valid_graph :: "graph \<Rightarrow> bool" where
  "valid_graph (Graph G) \<longleftrightarrow> (\<forall>i<length G. length (G ! i) = length G)"
setup \<open>add_rewrite_rule @{thm valid_graph.simps}\<close>

subsection \<open>Paths on graphs\<close>

text \<open>The set of vertices less than n.\<close>
definition verts :: "graph \<Rightarrow> nat set" where
  "verts G = {i. i < size G}"

lemma verts_mem [rewrite]: "i \<in> verts G \<longleftrightarrow> i < size G" by (simp add: verts_def)
lemma card_verts [rewrite]: "card (verts G) = size G" using verts_def by auto
lemma finite_verts [forward]: "finite (verts G)" using verts_def by auto

definition is_path :: "graph \<Rightarrow> nat list \<Rightarrow> bool" where [rewrite]:
  "is_path G p \<longleftrightarrow> p \<noteq> [] \<and> set p \<subseteq> verts G"

lemma is_path_to_in_verts [forward]: "is_path G p \<Longrightarrow> hd p \<in> verts G \<and> last p \<in> verts G"
@proof @have "last p \<in> set p" @qed

definition joinable :: "graph \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> bool" where [rewrite]:
  "joinable G p q \<longleftrightarrow> (is_path G p \<and> is_path G q \<and> last p = hd q)"

definition path_join :: "graph \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> nat list" where [rewrite]:
  "path_join G p q = p @ tl q"
setup \<open>register_wellform_data ("path_join G p q", ["joinable G p q"])\<close>
setup \<open>add_prfstep_check_req ("path_join G p q", "joinable G p q")\<close>

lemma path_join_is_path:
  "joinable G p q \<Longrightarrow> is_path G (path_join G p q)"
@proof @have "q = hd q # tl q" @qed
setup \<open>add_forward_prfstep_cond @{thm path_join_is_path} [with_term "path_join ?G ?p ?q"]\<close>

fun path_weight :: "graph \<Rightarrow> nat list \<Rightarrow> nat" where
  "path_weight G [] = 0"
| "path_weight G (x # xs) = (if xs = [] then 0 else weight G x (hd xs) + path_weight G xs)"
setup \<open>fold add_rewrite_rule @{thms path_weight.simps}\<close>

lemma path_weight_singleton [rewrite]: "path_weight G [x] = 0" by auto2
lemma path_weight_doubleton [rewrite]: "path_weight G [m, n] = weight G m n" by auto2

lemma path_weight_sum [rewrite]:
  "joinable G p q \<Longrightarrow> path_weight G (path_join G p q) = path_weight G p + path_weight G q"
@proof @induct p @qed

fun path_set :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list set" where
  "path_set G m n = {p. is_path G p \<and> hd p = m \<and> last p = n}"

lemma path_set_mem [rewrite]:
  "p \<in> path_set G m n \<longleftrightarrow> is_path G p \<and> hd p = m \<and> last p = n" by simp

lemma path_join_set: "joinable G p q \<Longrightarrow> path_join G p q \<in> path_set G (hd p) (last q)"
@proof @have "q = hd q # tl q" @case "tl q = []" @qed
setup \<open>add_forward_prfstep_cond @{thm path_join_set} [with_term "path_join ?G ?p ?q"]\<close>

subsection \<open>Shortest paths\<close>

definition is_shortest_path :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool" where [rewrite]:
  "is_shortest_path G m n p \<longleftrightarrow>
     (p \<in> path_set G m n \<and> (\<forall>p'\<in>path_set G m n. path_weight G p' \<ge> path_weight G p))"

lemma is_shortest_pathD1 [forward]:
  "is_shortest_path G m n p \<Longrightarrow> p \<in> path_set G m n" by auto2

lemma is_shortest_pathD2 [forward]:
  "is_shortest_path G m n p \<Longrightarrow> p' \<in> path_set G m n \<Longrightarrow> path_weight G p' \<ge> path_weight G p" by auto2
setup \<open>del_prfstep_thm_eqforward @{thm is_shortest_path_def}\<close>

definition has_dist :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "has_dist G m n \<longleftrightarrow> (\<exists>p. is_shortest_path G m n p)"

lemma has_distI [forward]: "is_shortest_path G m n p \<Longrightarrow> has_dist G m n" by auto2
lemma has_distD [resolve]: "has_dist G m n \<Longrightarrow> \<exists>p. is_shortest_path G m n p" by auto2
lemma has_dist_to_in_verts [forward]: "has_dist G u v \<Longrightarrow> u \<in> verts G \<and> v \<in> verts G" by auto2
setup \<open>del_prfstep_thm @{thm has_dist_def}\<close>

definition dist :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where [rewrite]:
  "dist G m n = path_weight G (SOME p. is_shortest_path G m n p)"
setup \<open>register_wellform_data ("dist G m n", ["has_dist G m n"])\<close>

lemma dist_eq [rewrite]:
  "is_shortest_path G m n p \<Longrightarrow> dist G m n = path_weight G p" by auto2

lemma distD [forward]:
  "has_dist G m n \<Longrightarrow> p \<in> path_set G m n \<Longrightarrow> path_weight G p \<ge> dist G m n" by auto2
setup \<open>del_prfstep_thm @{thm dist_def}\<close>

lemma shortest_init [resolve]: "n \<in> verts G \<Longrightarrow> is_shortest_path G n n [n]" by auto2

subsection \<open>Interior points\<close>

text \<open>List of interior points\<close>
definition int_pts :: "nat list \<Rightarrow> nat set" where [rewrite]:
  "int_pts p = set (butlast p)"

lemma int_pts_singleton [rewrite]: "int_pts [x] = {}" by auto2
lemma int_pts_doubleton [rewrite]: "int_pts [x, y] = {x}" by auto2

definition path_set_on :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat set \<Rightarrow> nat list set" where
  "path_set_on G m n V = {p. p \<in> path_set G m n \<and> int_pts p \<subseteq> V}"

lemma path_set_on_mem [rewrite]:
  "p \<in> path_set_on G m n V \<longleftrightarrow> p \<in> path_set G m n \<and> int_pts p \<subseteq> V" by (simp add: path_set_on_def)

text \<open>Version of shortest path on a set of points\<close>
definition is_shortest_path_on :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat set \<Rightarrow> bool" where [rewrite]:
  "is_shortest_path_on G m n p V \<longleftrightarrow>
    (p \<in> path_set_on G m n V \<and> (\<forall>p'\<in>path_set_on G m n V. path_weight G p' \<ge> path_weight G p))"

lemma is_shortest_path_onD1 [forward]:
  "is_shortest_path_on G m n p V \<Longrightarrow> p \<in> path_set_on G m n V" by auto2

lemma is_shortest_path_onD2 [forward]:
  "is_shortest_path_on G m n p V \<Longrightarrow> p' \<in> path_set_on G m n V \<Longrightarrow> path_weight G p' \<ge> path_weight G p" by auto2
setup \<open>del_prfstep_thm_eqforward @{thm is_shortest_path_on_def}\<close>

definition has_dist_on :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat set \<Rightarrow> bool" where [rewrite]:
  "has_dist_on G m n V \<longleftrightarrow> (\<exists>p. is_shortest_path_on G m n p V)"

lemma has_dist_onI [forward]: "is_shortest_path_on G m n p V \<Longrightarrow> has_dist_on G m n V" by auto2
lemma has_dist_onD [resolve]: "has_dist_on G m n V \<Longrightarrow> \<exists>p. is_shortest_path_on G m n p V" by auto2
setup \<open>del_prfstep_thm @{thm has_dist_on_def}\<close>

definition dist_on :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat set \<Rightarrow> nat" where [rewrite]:
  "dist_on G m n V = path_weight G (SOME p. is_shortest_path_on G m n p V)"
setup \<open>register_wellform_data ("dist_on G m n V", ["has_dist_on G m n V"])\<close>

lemma dist_on_eq [rewrite]:
  "is_shortest_path_on G m n p V \<Longrightarrow> dist_on G m n V = path_weight G p" by auto2

lemma dist_onD [forward]:
  "has_dist_on G m n V \<Longrightarrow> p \<in> path_set_on G m n V \<Longrightarrow> path_weight G p \<ge> dist_on G m n V" by auto2
setup \<open>del_prfstep_thm @{thm dist_on_def}\<close>

subsection \<open>Two splitting lemmas\<close>

lemma path_split1 [backward]: "is_path G p \<Longrightarrow> hd p \<in> V \<Longrightarrow> last p \<notin> V \<Longrightarrow>
  \<exists>p1 p2. joinable G p1 p2 \<and> p = path_join G p1 p2 \<and> int_pts p1 \<subseteq> V \<and> hd p2 \<notin> V"
@proof @induct p @with
  @subgoal "p = a # p'"
    @let "p = a # p'"
    @case "p' = []"
    @case "hd p' \<notin> V" @with @have "p = path_join G [a, hd p'] p'" @end
    @obtain p1 p2 where "joinable G p1 p2" "p' = path_join G p1 p2" "int_pts p1 \<subseteq> V" "hd p2 \<notin> V"
    @have "p = path_join G (a # p1) p2"
  @endgoal @end
@qed

lemma path_split2 [backward]: "is_path G p \<Longrightarrow> hd p \<noteq> last p \<Longrightarrow>
  \<exists>q n. joinable G q [n, last p] \<and> p = path_join G q [n, last p]"
@proof
  @have "p = butlast p @ [last p]"
  @have "butlast p \<noteq> []"
  @let "n = last (butlast p)"
  @have "p = path_join G (butlast p) [n, last p]"
@qed

subsection \<open>Deriving has\_dist and has\_dist\_on\<close>

definition known_dists :: "graph \<Rightarrow> nat set \<Rightarrow> bool" where [rewrite]:
  "known_dists G V \<longleftrightarrow> (V \<subseteq> verts G \<and> 0 \<in> V \<and>
      (\<forall>i\<in>verts G. has_dist_on G 0 i V) \<and>
      (\<forall>i\<in>V. has_dist G 0 i \<and> dist G 0 i = dist_on G 0 i V))"

lemma derive_dist [backward2]:
  "known_dists G V \<Longrightarrow>
   m \<in> verts G - V \<Longrightarrow>
   \<forall>i\<in>verts G - V. dist_on G 0 i V \<ge> dist_on G 0 m V \<Longrightarrow>
   has_dist G 0 m \<and> dist G 0 m = dist_on G 0 m V"
@proof
  @obtain p where "is_shortest_path_on G 0 m p V"
  @have "is_shortest_path G 0 m p" @with
    @have "p \<in> path_set G 0 m"
    @have "\<forall>p'\<in>path_set G 0 m. path_weight G p' \<ge> path_weight G p" @with
      @obtain p1 p2 where "joinable G p1 p2" "p' = path_join G p1 p2"
                          "int_pts p1 \<subseteq> V" "hd p2 \<notin> V"
      @let "x = last p1"
      @have "dist_on G 0 x V \<ge> dist_on G 0 m V"
      @have "p1 \<in> path_set_on G 0 x V"
      @have "path_weight G p1 \<ge> dist_on G 0 x V"
      @have "path_weight G p' \<ge> dist_on G 0 m V + path_weight G p2"
    @end
  @end
@qed

lemma join_def' [resolve]: "joinable G p q \<Longrightarrow> path_join G p q = butlast p @ q"
@proof
  @have "p = butlast p @ [last p]"
  @have "path_join G p q = butlast p @ [last p] @ tl q"
@qed

lemma int_pts_join [rewrite]:
  "joinable G p q \<Longrightarrow> int_pts (path_join G p q) = int_pts p \<union> int_pts q"
@proof @have "path_join G p q = butlast p @ q" @qed

lemma dist_on_triangle_ineq [backward]:
  "has_dist_on G k m V \<Longrightarrow> has_dist_on G k n V \<Longrightarrow> V \<subseteq> verts G \<Longrightarrow> n \<in> verts G \<Longrightarrow> m \<in> V \<Longrightarrow>
   dist_on G k m V + weight G m n \<ge> dist_on G k n V"
@proof
  @obtain p where "is_shortest_path_on G k m p V"
  @let "pq = path_join G p [m, n]"
  @have "V \<union> {m} = V"
  @have "pq \<in> path_set_on G k n V"
@qed

lemma derive_dist_on [backward2]:
  "known_dists G V \<Longrightarrow>
   m \<in> verts G - V \<Longrightarrow>
   \<forall>i\<in>verts G - V. dist_on G 0 i V \<ge> dist_on G 0 m V \<Longrightarrow>
   V' = V \<union> {m} \<Longrightarrow>
   n \<in> verts G - V' \<Longrightarrow>
   has_dist_on G 0 n V' \<and> dist_on G 0 n V' = min (dist_on G 0 n V) (dist_on G 0 m V + weight G m n)"
@proof
  @have "has_dist G 0 m \<and> dist G 0 m = dist_on G 0 m V"
  @let "M = min (dist_on G 0 n V) (dist_on G 0 m V + weight G m n)"
  @have "\<forall>p\<in>path_set_on G 0 n V'. path_weight G p \<ge> M" @with
    @obtain q n' where "joinable G q [n', n]" "p = path_join G q [n', n]"
    @have "q \<in> path_set G 0 n'"
    @have "n' \<in> V'"
    @case "n' \<in> V" @with
      @have "dist_on G 0 n' V = dist G 0 n'"
      @have "path_weight G q \<ge> dist_on G 0 n' V"
      @have "path_weight G p \<ge> dist_on G 0 n' V + weight G n' n"
      @have "dist_on G 0 n' V + weight G n' n \<ge> dist_on G 0 n V"
    @end
    @have "n' = m"
    @have "path_weight G q \<ge> dist G 0 m"
    @have "path_weight G p \<ge> dist G 0 m + weight G m n"
  @end
  @case "dist_on G 0 m V + weight G m n \<ge> dist_on G 0 n V" @with
    @obtain p where "is_shortest_path_on G 0 n p V"
    @have "is_shortest_path_on G 0 n p V'" @with
      @have "p \<in> path_set_on G 0 n V'" @with @have "V \<subseteq> V'" @end
    @end
  @end
  @have "M = dist_on G 0 m V + weight G m n"
  @obtain pm where "is_shortest_path_on G 0 m pm V"
  @have "path_weight G pm = dist G 0 m"
  @let "p = path_join G pm [m, n]"
  @have "joinable G pm [m, n]"
  @have "path_weight G p = path_weight G pm + weight G m n"
  @have "is_shortest_path_on G 0 n p V'"
@qed

subsection \<open>Invariant for the Dijkstra's algorithm\<close>

text \<open>The state consists of an array maintaining the best estimates,
  and a heap containing estimates for the unknown vertices.\<close>
datatype state = State (est: "nat list") (heap: "(nat, nat) map")
setup \<open>add_simple_datatype "state"\<close>

definition unknown_set :: "state \<Rightarrow> nat set" where [rewrite]:
  "unknown_set S = keys_of (heap S)"

definition known_set :: "state \<Rightarrow> nat set" where [rewrite]:
  "known_set S = {..<length (est S)} - unknown_set S"

text \<open>Invariant: for every vertex, the estimate is at least the shortest distance.
  Furthermore, for the known vertices the estimate is exact.\<close>
definition inv :: "graph \<Rightarrow> state \<Rightarrow> bool" where [rewrite]:
  "inv G S \<longleftrightarrow> (let V = known_set S; W = unknown_set S; M = heap S in
      (length (est S) = size G \<and> known_dists G V \<and>
      keys_of M \<subseteq> verts G \<and>
      (\<forall>i\<in>W. M\<langle>i\<rangle> = Some (est S ! i)) \<and>
      (\<forall>i\<in>V. est S ! i = dist G 0 i) \<and>
      (\<forall>i\<in>verts G. est S ! i = dist_on G 0 i V)))"

lemma invE1 [forward]: "inv G S \<Longrightarrow> length (est S) = size G \<and> known_dists G (known_set S) \<and> unknown_set S \<subseteq> verts G" by auto2
lemma invE2 [forward]: "inv G S \<Longrightarrow> i \<in> known_set S \<Longrightarrow> est S ! i = dist G 0 i" by auto2
lemma invE3 [forward]: "inv G S \<Longrightarrow> i \<in> verts G \<Longrightarrow> est S ! i = dist_on G 0 i (known_set S)" by auto2
lemma invE4 [rewrite]: "inv G S \<Longrightarrow> i \<in> unknown_set S \<Longrightarrow> (heap S)\<langle>i\<rangle> = Some (est S ! i)" by auto2
setup \<open>del_prfstep_thm_str "@eqforward" @{thm inv_def}\<close>

lemma inv_unknown_set [rewrite]:
  "inv G S \<Longrightarrow> unknown_set S = verts G - known_set S" by auto2

lemma dijkstra_end_inv [forward]:
  "inv G S \<Longrightarrow> unknown_set S = {} \<Longrightarrow> \<forall>i\<in>verts G. has_dist G 0 i \<and> est S ! i = dist G 0 i" by auto2

subsection \<open>Starting state\<close>

definition dijkstra_start_state :: "graph \<Rightarrow> state" where [rewrite]:
  "dijkstra_start_state G =
     State (list (\<lambda>i. if i = 0 then 0 else weight G 0 i) (size G))
           (map_constr (\<lambda>i. i > 0) (\<lambda>i. weight G 0 i) (size G))"
setup \<open>register_wellform_data ("dijkstra_start_state G", ["size G > 0"])\<close>

lemma dijkstra_start_known_set [rewrite]:
  "size G > 0 \<Longrightarrow> known_set (dijkstra_start_state G) = {0}" by auto2

lemma dijkstra_start_unknown_set [rewrite]:
  "size G > 0 \<Longrightarrow> unknown_set (dijkstra_start_state G) = verts G - {0}" by auto2

lemma card_start_state [rewrite]:
  "size G > 0 \<Longrightarrow> card (unknown_set (dijkstra_start_state G)) = size G - 1"
@proof @have "0 \<in> verts G" @qed

text \<open>Starting start of Dijkstra's algorithm satisfies the invariant.\<close>
theorem dijkstra_start_inv [backward]:
  "size G > 0 \<Longrightarrow> inv G (dijkstra_start_state G)"
@proof
  @let "V = {0::nat}"
  @have "has_dist G 0 0 \<and> dist G 0 0 = 0" @with
    @have "is_shortest_path G 0 0 [0]" @end
  @have "has_dist_on G 0 0 V \<and> dist_on G 0 0 V = 0" @with
    @have "is_shortest_path_on G 0 0 [0] V" @end
  @have "V \<subseteq> verts G \<and> 0 \<in> V"
  @have (@rule) "\<forall>i\<in>verts G. i \<noteq> 0 \<longrightarrow> has_dist_on G 0 i V \<and> dist_on G 0 i V = weight G 0 i" @with
    @let "p = [0, i]"
    @have "is_shortest_path_on G 0 i p V" @with
      @have "p \<in> path_set_on G 0 i V"
      @have "\<forall>p'\<in>path_set_on G 0 i V. path_weight G p' \<ge> weight G 0 i" @with
        @obtain q n where "joinable G q [n, last p']" "p' = path_join G q [n, last p']"
        @have "n \<in> V" @have "n = 0"
        @have "path_weight G p' = path_weight G q + weight G 0 i"
      @end
    @end
  @end
@qed

subsection \<open>Step of Dijkstra's algorithm\<close>

fun dijkstra_step :: "graph \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state" where
  "dijkstra_step G m (State e M) =
    (let M' = delete_map m M;
         e' = list_update_set (\<lambda>i. i \<in> keys_of M') (\<lambda>i. min (e ! m + weight G m i) (e ! i)) e;
         M'' = map_update_all (\<lambda>i. e' ! i) M'
     in State e' M'')"
setup \<open>add_rewrite_rule @{thm dijkstra_step.simps}\<close>
setup \<open>register_wellform_data ("dijkstra_step G m S", ["inv G S", "m \<in> unknown_set S"])\<close>

lemma has_dist_on_larger [backward1]:
  "has_dist G m n \<Longrightarrow> has_dist_on G m n V \<Longrightarrow> dist_on G m n V = dist G m n \<Longrightarrow>
   has_dist_on G m n (V \<union> {x}) \<and> dist_on G m n (V \<union> {x}) = dist G m n"
@proof
  @obtain p where "is_shortest_path_on G m n p V"
  @let "V' = V \<union> {x}"
  @have "p \<in> path_set_on G m n V'" @with @have "V \<subseteq> V'" @end
  @have "is_shortest_path_on G m n p V'"
@qed

lemma dijkstra_step_unknown_set [rewrite]:
  "inv G S \<Longrightarrow> m \<in> unknown_set S \<Longrightarrow> unknown_set (dijkstra_step G m S) = unknown_set S - {m}" by auto2

lemma dijkstra_step_known_set [rewrite]:
  "inv G S \<Longrightarrow> m \<in> unknown_set S \<Longrightarrow> known_set (dijkstra_step G m S) = known_set S \<union> {m}" by auto2

text \<open>One step of Dijkstra's algorithm preserves the invariant.\<close>
theorem dijkstra_step_preserves_inv [backward]:
  "inv G S \<Longrightarrow> is_heap_min m (heap S) \<Longrightarrow> inv G (dijkstra_step G m S)"
@proof
  @let "V = known_set S" "V' = V \<union> {m}"
  @have (@rule) "\<forall>i\<in>V. has_dist G 0 i \<and> has_dist_on G 0 i V' \<and> dist_on G 0 i V' = dist G 0 i"
  @have "has_dist G 0 m \<and> dist G 0 m = dist_on G 0 m V"
  @have "has_dist_on G 0 m V' \<and> dist_on G 0 m V' = dist G 0 m"
  @have (@rule) "\<forall>i\<in>verts G - V'. has_dist_on G 0 i V' \<and> dist_on G 0 i V' = min (dist_on G 0 i V) (dist_on G 0 m V + weight G m i)"
  @let "S' = dijkstra_step G m S"
  @have "known_dists G V'"
  @have "\<forall>i\<in>V'. est S' ! i = dist G 0 i"
  @have "\<forall>i\<in>verts G. est S' ! i = dist_on G 0 i V'" @with @case "i \<in> V'" @end
@qed

definition is_dijkstra_step :: "graph \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where [rewrite]:
  "is_dijkstra_step G S S' \<longleftrightarrow> (\<exists>m. is_heap_min m (heap S) \<and> S' = dijkstra_step G m S)"

lemma is_dijkstra_stepI [backward2]:
  "is_heap_min m (heap S) \<Longrightarrow> dijkstra_step G m S = S' \<Longrightarrow> is_dijkstra_step G S S'" by auto2

lemma is_dijkstra_stepD1 [forward]:
  "inv G S \<Longrightarrow> is_dijkstra_step G S S' \<Longrightarrow> inv G S'" by auto2

lemma is_dijkstra_stepD2 [forward]:
  "inv G S \<Longrightarrow> is_dijkstra_step G S S' \<Longrightarrow> card (unknown_set S') = card (unknown_set S) - 1" by auto2
setup \<open>del_prfstep_thm @{thm is_dijkstra_step_def}\<close>

end


section "Stack Machine and Compilation"

theory ASM
imports AExp
begin

subsection "Stack Machine"

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk  =  n # stk" |
"exec1 (LOAD x) s stk  =  s(x) # stk" |
"exec1  ADD _ (j#i#stk)  =  (i + j) # stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
apply(induction is1 arbitrary: stk)
apply (auto)
done

subsection "Compilation"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = aval a s # stk"
apply(induction a arbitrary: stk)
apply (auto)
done

end


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

section \<open>Lists\<close>

theory Lists_Ex
  imports Mapping_Str
begin

text \<open>
  Examples on lists. The itrev example comes from
  \cite[Section 2.4]{prog-prove}.

  The development here of insertion and deletion on lists is
  essential for verifying functional binary search trees and
  red-black trees. The idea, following Nipkow~\cite{nipkow16},
  is that showing sorted-ness and preservation of multisets for trees
  should be done on the in-order traversal of the tree.
\<close>

subsection \<open>Linear time version of rev\<close>

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev []       ys = ys"
| "itrev (x # xs) ys = itrev xs (x # ys)"
setup \<open>fold add_rewrite_rule @{thms itrev.simps}\<close>

lemma itrev_eq_rev: "itrev x [] = rev x"
@proof
  @induct x for "\<forall>y. itrev x y = rev x @ y" arbitrary y
@qed

subsection \<open>Strict sorted\<close>

fun strict_sorted :: "'a::linorder list \<Rightarrow> bool" where
  "strict_sorted [] = True"
| "strict_sorted (x # ys) = ((\<forall>y\<in>set ys. x < y) \<and> strict_sorted ys)"
setup \<open>fold add_rewrite_rule @{thms strict_sorted.simps}\<close>

lemma strict_sorted_appendI [backward]:
  "strict_sorted xs \<and> strict_sorted ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x < y) \<Longrightarrow> strict_sorted (xs @ ys)"
@proof @induct xs @qed

lemma strict_sorted_appendE1 [forward]:
  "strict_sorted (xs @ ys) \<Longrightarrow> strict_sorted xs \<and> strict_sorted ys"
@proof @induct xs @qed

lemma strict_sorted_appendE2 [forward]:
  "strict_sorted (xs @ ys) \<Longrightarrow> x \<in> set xs \<Longrightarrow> \<forall>y\<in>set ys. x < y"
@proof @induct xs @qed

lemma strict_sorted_distinct [forward]: "strict_sorted l \<Longrightarrow> distinct l"
@proof @induct l @qed

subsection \<open>Ordered insert\<close>

fun ordered_insert :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "ordered_insert x [] = [x]"
| "ordered_insert x (y # ys) = (
    if x = y then (y # ys)
    else if x < y then x # (y # ys)
    else y # ordered_insert x ys)"
setup \<open>fold add_rewrite_rule @{thms ordered_insert.simps}\<close>

lemma ordered_insert_set [rewrite]:
  "set (ordered_insert x ys) = {x} \<union> set ys"
@proof @induct ys @qed

lemma ordered_insert_sorted [forward]:
  "strict_sorted ys \<Longrightarrow> strict_sorted (ordered_insert x ys)"
@proof @induct ys @qed

lemma ordered_insert_binary [rewrite]:
  "strict_sorted (xs @ a # ys) \<Longrightarrow> ordered_insert x (xs @ a # ys) =
    (if x < a then ordered_insert x xs @ a # ys
     else if x > a then xs @ a # ordered_insert x ys
     else xs @ a # ys)"
@proof @induct xs @qed

subsection \<open>Deleting an element\<close>

fun remove_elt_list :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "remove_elt_list x [] = []"
| "remove_elt_list x (y # ys) = (if y = x then remove_elt_list x ys else y # remove_elt_list x ys)"
setup \<open>fold add_rewrite_rule @{thms remove_elt_list.simps}\<close>

lemma remove_elt_list_set [rewrite]:
  "set (remove_elt_list x ys) = set ys - {x}"
@proof @induct ys @qed

lemma remove_elt_list_sorted [forward]:
  "strict_sorted ys \<Longrightarrow> strict_sorted (remove_elt_list x ys)"
@proof @induct ys @qed

lemma remove_elt_idem [rewrite]:
  "x \<notin> set ys \<Longrightarrow> remove_elt_list x ys = ys"
@proof @induct ys @qed

lemma remove_elt_list_binary [rewrite]:
  "strict_sorted (xs @ a # ys) \<Longrightarrow> remove_elt_list x (xs @ a # ys) =
    (if x < a then remove_elt_list x xs @ a # ys
     else if x > a then xs @ a # remove_elt_list x ys else xs @ ys)"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x < a" @with @have "x \<notin> set ys" @end
  @endgoal @end
@qed

subsection \<open>Ordered insertion into list of pairs\<close>

fun ordered_insert_pairs :: "'a::ord \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "ordered_insert_pairs x v [] = [(x, v)]"
| "ordered_insert_pairs x v (y # ys) = (
    if x = fst y then ((x, v) # ys)
    else if x < fst y then (x, v) # (y # ys)
    else y # ordered_insert_pairs x v ys)"
setup \<open>fold add_rewrite_rule @{thms ordered_insert_pairs.simps}\<close>

lemma ordered_insert_pairs_map [rewrite]:
  "map_of_alist (ordered_insert_pairs x v ys) = update_map (map_of_alist ys) x v"
@proof @induct ys @qed

lemma ordered_insert_pairs_set [rewrite]:
  "set (map fst (ordered_insert_pairs x v ys)) = {x} \<union> set (map fst ys)"
@proof @induct ys @qed

lemma ordered_insert_pairs_sorted [backward]:
  "strict_sorted (map fst ys) \<Longrightarrow> strict_sorted (map fst (ordered_insert_pairs x v ys))"
@proof @induct ys @qed

lemma ordered_insert_pairs_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> ordered_insert_pairs x v (xs @ a # ys) =
    (if x < fst a then ordered_insert_pairs x v xs @ a # ys
     else if x > fst a then xs @ a # ordered_insert_pairs x v ys
     else xs @ (x, v) # ys)"
@proof @induct xs @qed

subsection \<open>Deleting from a list of pairs\<close>

fun remove_elt_pairs :: "'a \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "remove_elt_pairs x [] = []"
| "remove_elt_pairs x (y # ys) = (if fst y = x then ys else y # remove_elt_pairs x ys)"
setup \<open>fold add_rewrite_rule @{thms remove_elt_pairs.simps}\<close>

lemma remove_elt_pairs_map [rewrite]:
  "strict_sorted (map fst ys) \<Longrightarrow> map_of_alist (remove_elt_pairs x ys) = delete_map x (map_of_alist ys)"
@proof @induct ys @with
  @subgoal "ys = y # ys'"
    @case "fst y = x" @with @have "x \<notin> set (map fst ys')" @end
  @endgoal @end
@qed

lemma remove_elt_pairs_on_set [rewrite]:
  "strict_sorted (map fst ys) \<Longrightarrow> set (map fst (remove_elt_pairs x ys)) = set (map fst ys) - {x}"
@proof @induct ys @qed

lemma remove_elt_pairs_sorted [backward]:
  "strict_sorted (map fst ys) \<Longrightarrow> strict_sorted (map fst (remove_elt_pairs x ys))"
@proof @induct ys @qed

lemma remove_elt_pairs_idem [rewrite]:
  "x \<notin> set (map fst ys) \<Longrightarrow> remove_elt_pairs x ys = ys"
@proof @induct ys @qed

lemma remove_elt_pairs_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> remove_elt_pairs x (xs @ a # ys) =
    (if x < fst a then remove_elt_pairs x xs @ a # ys
     else if x > fst a then xs @ a # remove_elt_pairs x ys else xs @ ys)"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x < fst a" @with @have "x \<notin> set (map fst ys)" @end
  @endgoal @end
@qed

subsection \<open>Search in a list of pairs\<close>

lemma map_of_alist_binary [rewrite]:
  "strict_sorted (map fst (xs @ a # ys)) \<Longrightarrow> (map_of_alist (xs @ a # ys))\<langle>x\<rangle> =
   (if x < fst a then (map_of_alist xs)\<langle>x\<rangle>
    else if x > fst a then (map_of_alist ys)\<langle>x\<rangle> else Some (snd a))"
@proof @induct xs @with
  @subgoal "xs = []"
    @case "x \<notin> set (map fst ys)"
  @endgoal @end
@qed

end


(*
  File:     Error_Function_Asymptotics.thy
  Author:   Manuel Eberl, TU München

  The asymptotics of the real error function
*)
subsection \<open>Asymptotics\<close>
theory Error_Function_Asymptotics
  imports Error_Function Landau_Symbols.Landau_More
begin

lemma real_powr_eq_powerI:
  "x > 0 \<Longrightarrow> y = real y' \<Longrightarrow> x powr y = x ^ y'"
  by (simp add: powr_realpow)

definition erf_remainder_integral where
  "erf_remainder_integral n x =
     lim (\<lambda>m. integral {x..x + real m} (\<lambda>t. exp (-(t^2)) / t ^ (2*n)))"

text \<open>
  The following is the remainder term in the asymptotic expansion of @{term erfc}.
\<close>
definition erf_remainder where
  "erf_remainder n x =
     ((-1)^n * 2 * fact (2*n)) / (sqrt pi * 4 ^ n * fact n) *
     erf_remainder_integral n x"

lemma erf_remainder_integral_aux_nonneg:
  "x > 0 \<Longrightarrow> integral {x..x + real m} (\<lambda>t. exp (-(t^2)) / t ^ (2*n)) \<ge> 0"
  by (intro integral_nonneg integrable_continuous_real) (auto intro!: continuous_intros)

lemma erf_remainder_integral_aux_bound:
  assumes "x > 0"
  shows   "norm (integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n))) \<le> exp (-x\<^sup>2) / x ^ (2*n+1)"
    and   "integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n)) \<le> exp (-x\<^sup>2) / x ^ (2*n+1)"
proof -
  have "norm (integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n))) \<le>
          integral {x..x + real m} (\<lambda>t. exp (-x*t) / x ^ (2*n))"
  proof (intro integral_norm_bound_integral ballI)
    fix t assume t: "t \<in> {x..x + real m}"
    from t have "norm (exp (-t\<^sup>2) / t ^ (2*n)) = exp (-t\<^sup>2) / t ^ (2*n)" by simp
    also have "\<dots> \<le> exp (-x*t) / x ^ (2*n)" using t assms
      by (intro frac_le) (simp_all add: self_le_power power2_eq_square power_mono)
    finally show "norm (exp (-t\<^sup>2) / t ^ (2*n)) \<le> \<dots>" by simp
  qed (insert assms, auto intro!: continuous_intros integrable_continuous_real)
  also have "\<dots> = -exp (-x*(x + real m)) / x ^ (2*n+1) - (-exp (-x*x) / x ^ (2*n+1))"
    using assms
    by (intro integral_unique fundamental_theorem_of_calculus)
       (auto simp: has_field_derivative_iff_has_vector_derivative [symmetric]
             intro!: derivative_eq_intros)
  also have "\<dots> \<le> exp (-x\<^sup>2) / x ^ (2*n+1)" using assms by (simp add: power2_eq_square)
  finally show *: "norm (integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n))) \<le>
                      exp (-x\<^sup>2) / x ^ (2*n+1)" .
  have "integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n)) \<le>
          norm (integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n)))" by simp
  also note *
  finally show "integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n)) \<le> exp (-x\<^sup>2) / x ^ (2*n+1)" .
qed

lemma convergent_erf_remainder_integral:
  assumes "x > 0"
  shows   "convergent (\<lambda>m. integral {x..x + real m} (\<lambda>t. exp (-(t^2)) / t ^ (2*n)))"
proof (intro Bseq_mono_convergent BseqI'; clarify?)
  fix m :: nat
  show "norm (integral {x..x + real m} (\<lambda>t. exp (-t\<^sup>2) / t ^ (2*n))) \<le> exp (-x\<^sup>2) / x ^ (2*n+1)"
    using assms by (rule erf_remainder_integral_aux_bound)
qed (insert assms, auto intro!: integral_subset_le integrable_continuous_real continuous_intros)

lemma LIMSEQ_erf_remainder_integral:
  "x > 0 \<Longrightarrow> (\<lambda>m. integral {x..x + real m} (\<lambda>t. exp (-(t^2)) / t ^ (2*n))) \<longlonglongrightarrow>
                 erf_remainder_integral n x"
  using convergent_erf_remainder_integral[of x]
  by (simp add: convergent_LIMSEQ_iff erf_remainder_integral_def)

text \<open>
  We show some bounds on the remainder term.
\<close>
lemma
  assumes "x > 0"
  shows   erf_remainder_integral_nonneg: "erf_remainder_integral n x \<ge> 0"
    and   erf_remainder_integral_bound:  "erf_remainder_integral n x \<le> exp (-x\<^sup>2) / x ^ (2*n+1)"
proof -
  note * = LIMSEQ_erf_remainder_integral[OF assms]
  show "erf_remainder_integral n x \<ge> 0"
    by (intro tendsto_le[OF _ * tendsto_const] always_eventually
          erf_remainder_integral_aux_nonneg allI assms sequentially_bot)
  show "erf_remainder_integral n x \<le> exp (-x\<^sup>2) / x ^ (2*n+1)"
    by (intro tendsto_le[OF _ tendsto_const *] always_eventually
          erf_remainder_integral_aux_bound allI assms sequentially_bot)
qed

lemma erf_remainder_integral_bigo:
  "erf_remainder_integral n \<in> O(\<lambda>x. exp (-x\<^sup>2) / x ^ (2*n+1))"
  using erf_remainder_integral_nonneg erf_remainder_integral_bound
  by (auto intro!: bigoI[of _ 1] eventually_mono [OF eventually_gt_at_top[of "0::real"]])

theorem erf_remainder_bigo: "erf_remainder n \<in> O(\<lambda>x. exp (-x\<^sup>2) / x ^ (2*n+1))"
  using erf_remainder_integral_bigo[of n] by (simp add: erf_remainder_def [abs_def])

text \<open>
  Next, we unroll the remainder term to develop the asymptotic expansion.
\<close>
lemma erf_remainder_integral_0_conv_erfc:
  assumes "(x::real) > 0"
  shows   "erf_remainder_integral 0 x = sqrt pi / 2 * erfc x"
proof -
  have "(\<lambda>m. sqrt pi / 2 * (erf (x + real m) - erf x)) \<longlonglongrightarrow> sqrt pi / 2 * erfc x"
    (is "filterlim ?f _ _") unfolding erfc_def
    by (intro tendsto_intros filterlim_tendsto_add_at_top[OF
          tendsto_const filterlim_real_sequentially])
  also have "?f = (\<lambda>m. integral {x..x+real m} (\<lambda>t. exp (-t\<^sup>2)))"
    by (auto simp: fun_eq_iff integral_unique[OF integral_exp_minus_squared_real])
  finally have "(\<lambda>m. integral {x..x + real m} (\<lambda>t. exp (- t\<^sup>2))) \<longlonglongrightarrow> sqrt pi / 2 * erfc x" .
  moreover have "(\<lambda>m. integral {x..x + real m} (\<lambda>t. exp (- t\<^sup>2))) \<longlonglongrightarrow> erf_remainder_integral 0 x"
    using LIMSEQ_erf_remainder_integral[of x 0] assms by simp
  ultimately show "erf_remainder_integral 0 x = sqrt pi / 2 * erfc x"
    by (intro LIMSEQ_unique)
qed

text \<open>
  The first remainder is the @{term erfc} function itself.
\<close>
lemma erf_remainder_0_conv_erfc: "x > 0 \<Longrightarrow> erf_remainder 0 x = erfc x"
  by (simp add: erf_remainder_def erf_remainder_integral_0_conv_erfc)

text \<open>
  Also, the following recurrence allows us to get the next term of the asymptotic expansion.
\<close>
lemma erf_remainder_integral_conv_Suc:
  assumes "x > 0"
  shows   "erf_remainder_integral n x = exp (-x\<^sup>2) / (2*x^(2*n+1)) -
             real (2*n+1) / 2 * erf_remainder_integral (Suc n) x"
proof -
  let ?A = "\<lambda>m. {x..x + real m}"
  let ?J = "\<lambda>m n. integral {x..x+real m} (\<lambda>t. exp(-t\<^sup>2) / t ^ (2*n))"
  define I where
    "I = (\<lambda>m. exp (- (x + real m)\<^sup>2) / (- 2 * (x + real m) ^ (2 * n + 1)) -
              exp (- x\<^sup>2) * inverse (- 2 * x ^ (2 * n + 1)) - real (2*n+1)/2 * ?J m (Suc n))"

  have I_eq: "I = (\<lambda>m. integral (?A m) (\<lambda>t. exp (- t\<^sup>2) / t ^ (2 * n)))"
  proof
    fix m :: nat
    have "((\<lambda>t. (-2*t*exp (-(t^2))) * inverse (-2*t^(2*n+1))) has_integral I m) (?A m)"
    proof (rule integration_by_parts[OF bounded_bilinear_mult])
      fix t assume t: "t \<in> ?A m"
      with assms show "((\<lambda>t. exp (-(t^2))) has_vector_derivative -2*t*exp (-(t^2))) (at t)"
        by (auto simp: has_field_derivative_iff_has_vector_derivative [symmetric]
                       field_simps intro!: derivative_eq_intros)
      from assms t have "((\<lambda>t. -(1/2) * t powr (-2*n-1)) has_field_derivative
                           (2*n+1)/2 * t powr (-2*n-2)) (at t)"
        by (auto intro!: derivative_eq_intros simp: field_simps powr_numeral power2_eq_square
                         powr_minus powr_divide [symmetric] powr_add)
      also have "?this \<longleftrightarrow> ((\<lambda>t. inverse (-2*t^(2*n+1))) has_field_derivative
                              (2*n+1)/2 / t ^ (2*Suc n)) (at t)" using t
        using eventually_nhds_in_open[of "{0<..}" t] assms
        by (intro DERIV_cong_ev refl)
           (auto elim!: eventually_mono simp: powr_minus field_simps powr_diff
                        powr_realpow power2_eq_square intro!: real_powr_eq_powerI)
      finally show "((\<lambda>t. inverse (-2*t^(2*n+1))) has_vector_derivative
                              (2*n+1)/2 / t ^ (2*Suc n)) (at t)"
        by (simp add: has_field_derivative_iff_has_vector_derivative)
    next
      have "((\<lambda>t. real (2*n+1)/2 * (exp (- t\<^sup>2) / t ^ (2 * Suc n))) has_integral
             real (2*n+1)/2 * ?J m (Suc n)) (?A m)" (is "(?f has_integral ?a) _")
        using assms
        by (intro has_integral_mult_right integrable_integral integrable_continuous_real)
           (auto intro!: continuous_intros)
      also have "?f = (\<lambda>t. exp (- t\<^sup>2) * (real (2 * n + 1) / 2 / t ^ (2 * Suc n)))"
        by (simp add: fun_eq_iff field_simps)
      also have "?a = exp (- (x + real m)\<^sup>2) * inverse (- 2 * (x + real m) ^ (2 * n + 1)) -
                          exp (- x\<^sup>2) * inverse (- 2 * x ^ (2 * n + 1)) - I m" using assms
        by (simp add: I_def algebra_simps inverse_eq_divide)
      finally show "((\<lambda>t. exp (- t\<^sup>2) * (real (2 * n + 1) / 2 / t ^ (2 * Suc n))) has_integral \<dots>)
                      {x..x + real m}" .
    qed (insert assms, auto intro!: continuous_intros)
    hence "I m = integral {x..x + real m} (\<lambda>t. - 2*t*exp (- t\<^sup>2) * inverse (-2*t^(2 * n + 1)))"
      by (simp add: has_integral_iff)
    also have "\<dots> = integral {x..x + real m} (\<lambda>t. exp (- t\<^sup>2) / t ^ (2*n))"
      using assms by (intro integral_cong) (simp_all add: field_simps)
    finally show "I m = \<dots>" .
  qed

  have "filterlim (\<lambda>m. (-exp (- (x + real m)\<^sup>2)) / (2 * (x + real m) ^ (2 * n + 1)))
          (nhds 0) at_top"
    by (rule real_tendsto_divide_at_top filterlim_real_sequentially tendsto_minus
             filterlim_compose[OF exp_at_bot] filterlim_compose[OF filterlim_uminus_at_bot_at_top]
             filterlim_pow_at_top filterlim_tendsto_add_at_top tendsto_const filterlim_ident
             filterlim_tendsto_pos_mult_at_top | simp)+
  hence *: "filterlim (\<lambda>m. (exp (- (x + real m)\<^sup>2)) / (-2 * (x + real m) ^ (2 * n + 1)))
              (nhds 0) at_top" by (simp add: add_ac)
  have "I \<longlonglongrightarrow> 0 - exp (- x\<^sup>2) * inverse (- 2 * x ^ (2 * n + 1)) -
                  real (2 * n + 1) / 2 * erf_remainder_integral (Suc n) x"
    unfolding I_def
    by (intro tendsto_diff * tendsto_const tendsto_mult LIMSEQ_erf_remainder_integral assms)
  moreover from LIMSEQ_erf_remainder_integral[OF assms, of n] I_eq
    have "I \<longlonglongrightarrow> erf_remainder_integral n x"  by simp
  ultimately have "0 - exp (- x\<^sup>2) * inverse (- 2 * x ^ (2 * n + 1)) - real (2 * n + 1) / 2 *
                     erf_remainder_integral (Suc n) x = erf_remainder_integral n x"
    by (rule LIMSEQ_unique)
  thus ?thesis by (simp add: field_simps)
qed

lemma erf_remainder_conv_Suc:
  assumes "x > 0"
  shows   "erf_remainder n x = (- 1) ^ n * fact (2 * n) / (sqrt pi * 4 ^ n * fact n) *
                    exp (- x\<^sup>2) / (x ^ (2 * n + 1)) + erf_remainder (Suc n) x"
proof -
  have "erf_remainder n x =
          (- 1) ^ n * 2 * fact (2 * n) / (sqrt pi * 4 ^ n * fact n) *
             exp (- x\<^sup>2) / (2 * x ^ (2 * n + 1)) + -(
          (- 1) ^ n * 2 * fact (2 * n) / (sqrt pi * 4 ^ n * fact n) *
            real (2 * n + 1) / 2 * erf_remainder_integral (Suc n) x)" (is "_ = ?A + ?B")
    unfolding erf_remainder_def using assms
    by (subst erf_remainder_integral_conv_Suc)
       (auto simp: assms algebra_simps simp del: power_Suc)
  also have "?B = erf_remainder (Suc n) x"
    by (simp add: divide_simps erf_remainder_def)
  also have "?A = (- 1) ^ n * fact (2 * n) / (sqrt pi * 4 ^ n * fact n) *
                    exp (- x\<^sup>2) / (x ^ (2 * n + 1))"
    by (simp add: divide_simps)
  finally show ?thesis .
qed

text \<open>
  Finally, this gives us the full asymptotic expansion for @{term erfc}:
\<close>
theorem erfc_unroll:
  assumes "x > 0"
  shows   "erfc x = exp (-x\<^sup>2) / sqrt pi *
             (\<Sum>i<n. (-1)^i * fact (2*i) / (4^i*fact i) / x^(2*i+1)) + erf_remainder n x"
proof (induction n)
  case (Suc n)
  note Suc.IH
  also note erf_remainder_conv_Suc[OF assms, of n]
  also have "exp (- x\<^sup>2) / sqrt pi *
               (\<Sum>i<n. (- 1) ^ i * fact (2 * i) / (4 ^ i * fact i) / x ^ (2*i+1)) +
                 ((- 1) ^ n * fact (2*n) / (sqrt pi * 4 ^ n * fact n) * exp (- x\<^sup>2) / x^(2*n+1) +
                 erf_remainder (Suc n) x) =
               exp (- x\<^sup>2) / sqrt pi *
                 (\<Sum>i<Suc n. (- 1) ^ i * fact (2 * i) / (4 ^ i * fact i) / x ^ (2 * i + 1)) +
                 erf_remainder (Suc n) x"
    by (subst sum.lessThan_Suc) (simp add: algebra_simps)
  finally show ?case .
qed (auto simp: assms erf_remainder_0_conv_erfc)

text \<open>
  For convenience, we define another auxiliary function that is more suitable for use in an
  automated expansion framework, since it has a simple asymptotic expansion in powers of $x$.
\<close>
definition erfc_aux where "erfc_aux x = exp (x\<^sup>2) * sqrt pi * erfc x"
definition erf_remainder' where "erf_remainder' n x = exp (x\<^sup>2) * sqrt pi * erf_remainder n x"

lemma erfc_aux_unroll:
  "x > 0 \<Longrightarrow>
     erfc_aux x = (\<Sum>i<n. (-1)^i * fact (2*i) / (4^i*fact i) / x^(2*i+1)) + erf_remainder' n x"
  using erfc_unroll[of x n]
  by (simp add: erfc_aux_def erf_remainder'_def exp_minus field_simps del: of_nat_Suc)

lemma erf_remainder'_bigo: "erf_remainder' n \<in> O(\<lambda>x. 1 / x ^ (2*n+1))"
proof -
  have "(\<lambda>x. exp (x\<^sup>2) * erf_remainder n x) \<in> O(\<lambda>x. exp (x\<^sup>2) * (exp (-x\<^sup>2) / x ^ (2*n+1)))"
    by (intro landau_o.big.mult erf_remainder_bigo) simp_all
  thus ?thesis by (simp add: exp_minus erf_remainder'_def [abs_def])
qed

lemma has_field_derivative_erfc_aux:
    "(erfc_aux has_field_derivative (2 * x * erfc_aux x - 2)) (at x)"
  by (auto simp: erfc_aux_def [abs_def] exp_minus field_simps intro!: derivative_eq_intros)

end


section "Vertex Cover"

theory Approx_VC_Hoare
imports "HOL-Hoare.Hoare_Logic"
begin

text \<open>The algorithm is classical, the proof is based on and augments the one
by Berghammer and M\"uller-Olm \<^cite>\<open>"BerghammerM03"\<close>.\<close>

subsection "Graph"

text \<open>A graph is simply a set of edges, where an edge is a 2-element set.\<close>

definition vertex_cover :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
"vertex_cover E C = (\<forall>e \<in> E. e \<inter> C \<noteq> {})"

abbreviation matching :: "'a set set \<Rightarrow> bool" where
"matching M \<equiv> pairwise disjnt M"

lemma card_matching_vertex_cover:
  "\<lbrakk> finite C;  matching M;  M \<subseteq> E;  vertex_cover E C \<rbrakk> \<Longrightarrow> card M \<le> card C"
apply(erule card_le_if_inj_on_rel[where r = "\<lambda>e v. v \<in> e"])
 apply (meson disjnt_def disjnt_iff vertex_cover_def subsetCE)
by (meson disjnt_iff pairwise_def)

subsection "The Approximation Algorithm"

text \<open>Formulated using a simple(!) predefined Hoare-logic.
This leads to a streamlined proof based on standard invariant reasoning.

The nondeterministic selection of an element from a set \<open>F\<close> is simulated by @{term "SOME x. x \<in> F"}.
The \<open>SOME\<close> operator is built into HOL: @{term "SOME x. P x"} denotes some \<open>x\<close> that satisfies \<open>P\<close>
if such an \<open>x\<close> exists; otherwise it denotes an arbitrary element. Note that there is no
actual nondeterminism involved: @{term "SOME x. P x"} is some fixed element
but in general we don't know which one. Proofs about \<open>SOME\<close> are notoriously tedious.
Typically it involves showing first that @{prop "\<exists>x. P x"}. Then @{thm someI_ex} implies
@{prop"P (SOME x. P x)"}. There are a number of (more) useful related theorems:
just click on @{thm someI_ex} to be taken there.\<close>

text \<open>Convenient notation for choosing an arbitrary element from a set:\<close>
abbreviation "some A \<equiv> SOME x. x \<in> A"

locale Edges =
  fixes E :: "'a set set"
  assumes finE: "finite E"
  assumes edges2: "e \<in> E \<Longrightarrow> card e = 2"
begin

text \<open>The invariant:\<close>

definition "inv_matching C F M =
  (matching M \<and> M \<subseteq> E \<and> card C \<le> 2 * card M \<and> (\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}))"

definition invar :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
"invar C F = (F \<subseteq> E \<and> vertex_cover (E-F) C \<and> finite C \<and> (\<exists>M. inv_matching C F M))"

text \<open>Preservation of the invariant by the loop body:\<close>

lemma approx_vertex_cover:
"VARS C F
  {True}
  C := {};
  F := E;
  WHILE F \<noteq> {}
  INV {invar C F}
  DO C := C \<union> some F;
     F := F - {e' \<in> F. some F \<inter> e' \<noteq> {}}
  OD
  {vertex_cover E C \<and> (\<forall>C'. finite C' \<and> vertex_cover E C' \<longrightarrow> card C \<le> 2 * card C')}"
proof (vcg, goal_cases)
  case (1 C F)
  have "inv_matching {} E {}" by (auto simp add: inv_matching_def)
  with 1 show ?case by (auto simp add: invar_def vertex_cover_def)
next
  case (2 C F)
  thus ?case using invar_step[of F C] by(auto simp: Let_def)
next
  case (3 C F)
  then obtain M :: "'a set set" where
    post: "vertex_cover E C" "matching M" "M \<subseteq> E" "card C \<le> 2 * card M"
    by(auto simp: invar_def inv_matching_def)

  have opt: "card C \<le> 2 * card C'" if C': "finite C'" "vertex_cover E C'" for C'
  proof -
    note post(4)
    also have "2 * card M \<le> 2 * card C'"
    using card_matching_vertex_cover[OF C'(1) post(2,3) C'(2)] by simp
    finally show "card C \<le> 2 * card C'" .
  qed

  show ?case using post(1) opt by auto
qed

end (* locale Graph *)

subsection "Version for Hypergraphs"

text \<open>Almost the same. We assume that the degree of every edge is bounded.\<close>

locale Bounded_Hypergraph =
  fixes E :: "'a set set"
  fixes k :: nat
  assumes finE: "finite E"
  assumes edge_bnd: "e \<in> E \<Longrightarrow> finite e \<and> card e \<le> k"
  assumes E1: "{} \<notin> E"
begin

definition "inv_matching C F M =
  (matching M \<and> M \<subseteq> E \<and> card C \<le> k * card M \<and> (\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}))"

definition invar :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
"invar C F = (F \<subseteq> E \<and> vertex_cover (E-F) C \<and> finite C \<and> (\<exists>M. inv_matching C F M))"

lemma invar_step:
  assumes "F \<noteq> {}" "invar C F"
  shows "invar (C \<union> some F) (F - {e' \<in> F. some F \<inter> e' \<noteq> {}})"
proof -
  from assms(2) obtain M where "F \<subseteq> E" and vc: "vertex_cover (E-F) C" and fC: "finite C"
    and m: "matching M" "M \<subseteq> E" and card: "card C \<le> k * card M"
    and disj: "\<forall>e \<in> M. \<forall>f \<in> F. e \<inter> f = {}"
  by (auto simp: invar_def inv_matching_def)
  let ?e = "SOME e. e \<in> F"
  have "?e \<in> F" using \<open>F \<noteq> {}\<close> by (simp add: some_in_eq)
  hence fe': "finite ?e" using \<open>F \<subseteq> E\<close> assms(2) edge_bnd by blast
  have "?e \<notin> M" using E1 \<open>?e \<in> F\<close> disj \<open>F \<subseteq> E\<close> by fastforce
  have card': "card (C \<union> ?e) \<le> k * card (insert ?e M)"
    using \<open>?e \<in> F\<close> \<open>?e \<notin> M\<close> card_Un_le[of C ?e] \<open>F \<subseteq> E\<close> edge_bnd card finite_subset[OF m(2) finE]
    by fastforce
  let ?M = "M \<union> {?e}"
  have vc': "vertex_cover (E - (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}})) (C \<union> ?e)"
    using vc by(auto simp: vertex_cover_def)
  have m': "inv_matching (C \<union> ?e) (F - {e' \<in> F. ?e \<inter> e' \<noteq> {}}) ?M"
    using m card' \<open>F \<subseteq> E\<close> \<open>?e \<in> F\<close> disj
    by(auto simp: inv_matching_def Int_commute disjnt_def pairwise_insert)
  show ?thesis using \<open>F \<subseteq> E\<close> vc' fC fe' m' by(auto simp add: invar_def Let_def)
qed

lemma approx_vertex_cover_bnd:
"VARS C F
  {True}
  C := {};
  F := E;
  WHILE F \<noteq> {}
  INV {invar C F}
  DO C := C \<union> some F;
     F := F - {e' \<in> F. some F \<inter> e' \<noteq> {}}
  OD
  {vertex_cover E C \<and> (\<forall>C'. finite C' \<and> vertex_cover E C' \<longrightarrow> card C \<le> k * card C')}"
proof (vcg, goal_cases)
  case (1 C F)
  have "inv_matching {} E {}" by (auto simp add: inv_matching_def)
  with 1 show ?case by (auto simp add: invar_def vertex_cover_def)
next
  case (2 C F)
  thus ?case using invar_step[of F C] by(auto simp: Let_def)
next
  case (3 C F)
  then obtain M :: "'a set set" where
    post: "vertex_cover E C" "matching M" "M \<subseteq> E" "card C \<le> k * card M"
    by(auto simp: invar_def inv_matching_def)

  have opt: "card C \<le> k * card C'" if C': "finite C'" "vertex_cover E C'" for C'
  proof -
    note post(4)
    also have "k * card M \<le> k * card C'"
    using card_matching_vertex_cover[OF C'(1) post(2,3) C'(2)] by simp
    finally show "card C \<le> k * card C'" .
  qed

  show ?case using post(1) opt by auto
qed

end (* locale Bounded_Hypergraph *)

end