section \<open>Load Balancing\<close>

theory Approx_LB_Hoare
  imports Complex_Main "HOL-Hoare.Hoare_Logic"
begin

text \<open>This is a formalization of the load balancing algorithms and proofs
in the book by Kleinberg and Tardos \cite{KleinbergT06}.\<close>

hide_const (open) sorted

(* TODO: mv *)

lemma sum_le_card_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
proof(induction A rule: finite_ne_induct)
  case (singleton x)
  then show ?case by simp
next
  case (insert x F)
  then show ?case by (auto simp: max_def order.trans[of "sum f F" "card F * Max (f ` F)"])
qed

lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
using Max_in image_is_empty by blast

abbreviation Max\<^sub>0 :: "nat set \<Rightarrow> nat" where
"Max\<^sub>0 N \<equiv> (if N={} then 0 else Max N)"

fun f_Max\<^sub>0 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "f_Max\<^sub>0 f 0 = 0"
| "f_Max\<^sub>0 f (Suc x) = max (f (Suc x)) (f_Max\<^sub>0 f x)"

lemma f_Max\<^sub>0_equiv: "f_Max\<^sub>0 f n = Max\<^sub>0 (f ` {1..n})"
  by (induction n) (auto simp: not_le atLeastAtMostSuc_conv)

lemma f_Max\<^sub>0_correct:
  "\<forall>x \<in> {1..m}. T x \<le> f_Max\<^sub>0 T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = f_Max\<^sub>0 T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma f_Max\<^sub>0_mono:
  "y \<le> T x \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) m \<le> f_Max\<^sub>0 T m"
  "T x \<le> y \<Longrightarrow> f_Max\<^sub>0 T m \<le> f_Max\<^sub>0 (T (x := y)) m"
  by (induction m) auto

lemma f_Max\<^sub>0_out_of_range [simp]:
  "x \<notin> {1..k} \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) k = f_Max\<^sub>0 T k"
  by (induction k) auto

lemma fun_upd_f_Max\<^sub>0:
  assumes "x \<in> {1..m}" "T x \<le> y"
  shows "f_Max\<^sub>0 (T (x := y)) m = max y (f_Max\<^sub>0 T m)"
  using assms by (induction m) auto

locale LoadBalancing = (* Load Balancing *)
  fixes t :: "nat \<Rightarrow> nat"
    and m :: nat
    and n :: nat
  assumes m_gt_0: "m > 0"
begin

subsection \<open>Formalization of a Correct Load Balancing\<close>

subsubsection \<open>Definition\<close>

definition lb :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "lb T A j = ((\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}) \<comment> \<open>No job is assigned to more than one machine\<close>
             \<and> (\<Union>x \<in> {1..m}. A x) = {1..j} \<comment> \<open>Every job is assigned\<close>
             \<and> (\<forall>x \<in> {1..m}. (\<Sum>j \<in> A x. t j) = T x) \<comment> \<open>The processing times sum up to the correct load\<close>)"

abbreviation makespan :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
  "makespan T \<equiv> f_Max\<^sub>0 T m"

lemma makespan_def': "makespan T = Max (T ` {1..m})"
  using m_gt_0 by (simp add: f_Max\<^sub>0_equiv)
(*
lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = makespan T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma no_machines_lb_iff_no_jobs: "lb T A j 0 \<longleftrightarrow> j = 0"
  unfolding lb_def by auto

lemma machines_if_jobs: "\<lbrakk> lb T A j m; j > 0 \<rbrakk> \<Longrightarrow> m > 0"
  using no_machines_lb_iff_no_jobs by (cases m) auto
*)

lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T"
  "\<exists>x \<in> {1..m}. T x = makespan T"
  using f_Max\<^sub>0_correct m_gt_0 by auto

lemma lbE:
  assumes "lb T A j"
  shows "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
        "(\<Union>x \<in> {1..m}. A x) = {1..j}"
        "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  using assms unfolding lb_def by blast+

lemma lbI:
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
          "(\<Union>x \<in> {1..m}. A x) = {1..j}"
          "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  shows "lb T A j" using assms unfolding lb_def by blast

lemma A_lb_finite [simp]:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "finite (A x)"
  by (metis lbE(2) assms finite_UN finite_atLeastAtMost)

text \<open>If \<open>A x\<close> is pairwise disjoint for all \<open>x \<in> {1..m}\<close>, then the the sum over the sums of the
      individual \<open>A x\<close> is equal to the sum over the union of all \<open>A x\<close>.\<close>
lemma sum_sum_eq_sum_Un:
  fixes A :: "nat \<Rightarrow> nat set"
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
      and "\<forall>x \<in> {1..m}. finite (A x)"
  shows "(\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y)) = (\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x)"
  using assms
proof (induction m)
  case (Suc m)
  have FINITE: "finite (\<Union>x \<in> {1..m}. A x)" "finite (A (Suc m))"
    using Suc.prems(2) by auto
  have "\<forall>x \<in> {1..m}. A x \<inter> A (Suc m) = {}"
    using Suc.prems(1) by simp
  then have DISJNT: "(\<Union>x \<in> {1..m}. A x) \<inter> (A (Suc m)) = {}" using Union_disjoint by blast
  have "(\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x) + (\<Sum>x \<in> A (Suc m). t x)
      = (\<Sum>x \<in> ((\<Union>y \<in> {1..m}. A y) \<union> A (Suc m)). t x)"
    using sum.union_disjoint[OF FINITE DISJNT, symmetric] .
  also have "... = (\<Sum>x \<in> (\<Union>y \<in> {1..Suc m}. A y). t x)"
    by (metis UN_insert image_Suc_lessThan image_insert inf_sup_aci(5) lessThan_Suc)
  finally show ?case using Suc by auto
qed simp

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines,
      then the sum of the loads has to be equal to the sum of the processing times of the jobs\<close>
lemma lb_impl_job_sum:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..j}. t x)"
proof -
  note lbrules = lbE[OF assms]
  from assms have FINITE: "\<forall>x \<in> {1..m}. finite (A x)" by simp
  have "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y))"
    using lbrules(3) by simp
  also have "... = (\<Sum>x \<in> {1..j}. t x)"
    using sum_sum_eq_sum_Un[OF lbrules(1) FINITE]
    unfolding lbrules(2) .
  finally show ?thesis .
qed

subsubsection \<open>Lower Bounds for the Makespan\<close>

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines, then the processing time
      of any job \<open>x \<in> {1..j}\<close> is a lower bound for the load of some machine \<open>y \<in> {1..m}\<close>\<close>
lemma job_lower_bound_machine:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "\<exists>y \<in> {1..m}. t x \<le> T y"
proof -
  note lbrules = lbE[OF assms(1)]
  have "\<exists>y \<in> {1..m}. x \<in> A y" using lbrules(2) assms(2) by blast
  then obtain y where y_def: "y \<in> {1..m}" "x \<in> A y" ..
  moreover have "finite (A y)" using assms(1) y_def(1) by simp
  ultimately have "t x \<le> (\<Sum>x \<in> A y. t x)" using lbrules(1) member_le_sum by fast
  also have "... = T y" using lbrules(3) y_def(1) by blast
  finally show ?thesis using y_def(1) by blast
qed

text \<open>As the load of any machine is a lower bound for the makespan, the processing time
      of any job \<open>x \<in> {1..j}\<close> has to also be a lower bound for the makespan.
      Follows from @{thm [source] job_lower_bound_machine} and @{thm [source] makespan_correct}.\<close>
lemma job_lower_bound_makespan:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "t x \<le> makespan T"
  by (meson job_lower_bound_machine[OF assms] makespan_correct(1) le_trans)

text \<open>The makespan over \<open>j\<close> jobs is a lower bound for the makespan of any correct load balancing for \<open>j\<close> jobs.\<close>
lemma max_job_lower_bound_makespan:
  assumes "lb T A j"
  shows "Max\<^sub>0 (t ` {1..j}) \<le> makespan T"
  using job_lower_bound_makespan[OF assms] by fastforce

lemma job_dist_lower_bound_makespan:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..j}. t x) / m \<le> makespan T"
proof -
  have "(\<Sum>x \<in> {1..j}. t x) \<le> m * makespan T"
    using assms lb_impl_job_sum[symmetric]
      and sum_le_card_Max[of "{1..m}"] m_gt_0 by (simp add: makespan_def')
  then have "real (\<Sum>x \<in> {1..j}. t x) \<le> real m * real (makespan T)"
    using of_nat_mono by fastforce
  then show ?thesis by (simp add: field_simps m_gt_0)
qed

subsection \<open>The Greedy Approximation Algorithm\<close>

text \<open>This function will perform a linear scan from \<open>k \<in> {1..m}\<close> and return the index of the machine with minimum load assuming \<open>m > 0\<close>\<close>
fun min\<^sub>k :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "min\<^sub>k T 0 = 1"
| "min\<^sub>k T (Suc x) =
   (let k = min\<^sub>k T x
    in if T (Suc x) < T k then (Suc x) else k)"

lemma min_correct:
  "\<forall>x \<in> {1..m}. T (min\<^sub>k T m) \<le> T x"
  by (induction m) (auto simp: Let_def le_Suc_eq, force)

lemma min_in_range:
  "k > 0 \<Longrightarrow> (min\<^sub>k T k) \<in> {1..k}"
  by (induction k) (auto simp: Let_def, force+)

lemma add_job:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "lb (T (x := T x + t (Suc j))) (A (x := A x \<union> {Suc j})) (Suc j)"
    (is \<open>lb ?T ?A _\<close>)
proof -
  note lbrules = lbE[OF assms(1)]

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. Suc j \<notin> A i" using lbrules(2) assms(2) by force
  with lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x \<union> {Suc j}) = {}"
    using assms(2) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by simp

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) \<union> {Suc j}"
    using UNION_fun_upd assms(2) by auto
  also have "... = {1..Suc j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..Suc j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x \<union> {Suc j}. t i)" by simp
  moreover have "A x \<inter> {Suc j} = {}" using NOTIN assms(2) by blast
  moreover have "finite (A x)" "finite {Suc j}" using assms by simp+
  ultimately have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x. t i) + (\<Sum>i \<in> {Suc j}. t i)"
    using sum.union_disjoint by simp
  also have "... = T x + t (Suc j)" using lbrules(3) assms(2) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) assms(2) by simp

  from lbI[OF 1 2 3] show ?thesis .
qed

lemma makespan_mono:
  "y \<le> T x \<Longrightarrow> makespan (T (x := y)) \<le> makespan T"
  "T x \<le> y \<Longrightarrow> makespan T \<le> makespan (T (x := y))"
  using f_Max\<^sub>0_mono by auto

lemma smaller_optimum:
  assumes "lb T A (Suc j)"
  shows "\<exists>T' A'. lb T' A' j \<and> makespan T' \<le> makespan T"
proof -
  note lbrules = lbE[OF assms]
  have "\<exists>x \<in> {1..m}. Suc j \<in> A x" using lbrules(2) by auto
  then obtain x where x_def: "x \<in> {1..m}" "Suc j \<in> A x" ..
  let ?T = "T (x := T x - t (Suc j))"
  let ?A = "A (x := A x - {Suc j})"

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  from lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x - {Suc j}) = {}"
    using x_def(1) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by auto

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> Suc j \<notin> A i" using lbrules(1) x_def by blast
  then have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) - {Suc j}"
    using UNION_fun_upd x_def by auto
  also have "... = {1..j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> A x - {Suc j}. t i) = (\<Sum>i \<in> A x. t i) - t (Suc j)"
    by (simp add: sum_diff1_nat x_def(2))
  also have "... = T x - t (Suc j)" using lbrules(3) x_def(1) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) x_def(1) by simp

  \<comment> \<open>@{term makespan} is not larger\<close>
  have "lb ?T ?A j \<and> makespan ?T \<le> makespan T"
    using lbI[OF 1 2 3] makespan_mono(1) by force
  then show ?thesis by blast
qed

text \<open>If the processing time \<open>y\<close> does not contribute to the makespan, we can ignore it.\<close>
lemma remove_small_job:
  assumes "makespan (T (x := T x + y)) \<noteq> T x + y"
  shows   "makespan (T (x := T x + y)) = makespan T"
proof -
  let ?T = "T (x := T x + y)"
  have NOT_X: "makespan ?T \<noteq> ?T x" using assms(1) by simp
  then have "\<exists>i \<in> {1..m}. makespan ?T = ?T i \<and> i \<noteq> x"
    using makespan_correct(2) by metis
  then obtain i where i_def: "i \<in> {1..m}" "makespan ?T = ?T i" "i \<noteq> x" by blast
  then have "?T i = T i" using NOT_X by simp
  moreover from this have "makespan T = T i"
    by (metis i_def(1,2) antisym_conv le_add1 makespan_mono(2) makespan_correct(1))
  ultimately show ?thesis using i_def(2) by simp
qed

lemma greedy_makespan_no_jobs [simp]:
  "makespan (\<lambda>_. 0) = 0"
  using m_gt_0 by (simp add: makespan_def')

lemma min_avg: "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)"
           (is \<open>_ * ?T \<le> ?S\<close>)
proof -
  have "(\<Sum>_ \<in> {1..m}. ?T) \<le> ?S"
    using sum_mono[of \<open>{1..m}\<close> \<open>\<lambda>_. ?T\<close> T]
      and min_correct by blast
  then show ?thesis by simp
qed

definition inv\<^sub>1 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>1 T A j = (lb T A j \<and> j \<le> n \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'))"

lemma inv\<^sub>1E:
  assumes "inv\<^sub>1 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 2 * makespan T'"
  using assms unfolding inv\<^sub>1_def by blast+

lemma inv\<^sub>1I:
  assumes "lb T A j" "j \<le> n" "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'"
  shows "inv\<^sub>1 T A j" using assms unfolding inv\<^sub>1_def by blast

lemma inv\<^sub>1_step:
  assumes "inv\<^sub>1 T A j" "j < n"
  shows "inv\<^sub>1 (T ((min\<^sub>k T m) := T (min\<^sub>k T m) + t (Suc j)))
              (A ((min\<^sub>k T m) := A (min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>1 ?T ?A _\<close>)
proof -
  note invrules = inv\<^sub>1E[OF assms(1)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
      case True
      have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "t (Suc j) \<le> makespan T\<^sub>1"
        using job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close>] by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  from inv\<^sub>1I[OF LB _ MK] show ?thesis using assms(2) by simp
qed

definition sorted :: "nat \<Rightarrow> bool" where
  "sorted j = (\<forall>x \<in> {1..j}. \<forall>y \<in> {1..x}. t x \<le> t y)"

lemma sorted_smaller [simp]: "\<lbrakk> sorted j; j \<ge> j' \<rbrakk> \<Longrightarrow> sorted j'"
  unfolding sorted_def by simp

lemma j_gt_m_pigeonhole:
  assumes "lb T A j" "j > m"
  shows "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. \<exists>z \<in> {1..m}. x \<noteq> y \<and> x \<in> A z \<and> y \<in> A z"
proof -
  have "\<forall>x \<in> {1..j}. \<exists>y \<in> {1..m}. x \<in> A y"
    using lbE(2)[OF assms(1)] by blast
  then have "\<exists>f. \<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" by metis
  then obtain f where f_def: "\<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" ..
  then have "card (f ` {1..j}) \<le> card {1..m}"
    by (meson card_mono finite_atLeastAtMost image_subset_iff)
  also have "... < card {1..j}" using assms(2) by simp
  finally have "card (f ` {1..j}) < card {1..j}" .
  then have "\<not> inj_on f {1..j}" using pigeonhole by blast
  then have "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. x \<noteq> y \<and> f x = f y"
    unfolding inj_on_def by blast
  then show ?thesis using f_def by metis
qed

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines with \<open>j > m\<close>,
      and the jobs are sorted in descending order, then there exists a machine \<open>x \<in> {1..m}\<close>
      whose load is at least twice as large as the processing time of job \<open>j\<close>.\<close>
lemma sorted_job_lower_bound_machine:
  assumes "lb T A j" "j > m" "sorted j"
  shows "\<exists>x \<in> {1..m}. 2 * t j \<le> T x"
proof -
  \<comment> \<open>Step 1: Obtaining the jobs\<close>
  note lbrules = lbE[OF assms(1)]
  obtain j\<^sub>1 j\<^sub>2 x where *:
    "j\<^sub>1 \<in> {1..j}" "j\<^sub>2 \<in> {1..j}" "x \<in> {1..m}" "j\<^sub>1 \<noteq> j\<^sub>2" "j\<^sub>1 \<in> A x" "j\<^sub>2 \<in> A x"
    using j_gt_m_pigeonhole[OF assms(1,2)] by blast

  \<comment> \<open>Step 2: Jobs contained in sum\<close>
  have "finite (A x)" using assms(1) *(3) by simp
  then have SUM: "(\<Sum>i \<in> A x. t i) = t j\<^sub>1 + t j\<^sub>2 + (\<Sum>i \<in> A x - {j\<^sub>1} - {j\<^sub>2}. t i)"
    using *(4-6) by (simp add: sum.remove)

  \<comment> \<open>Step 3: Proof of lower bound\<close>
  have "t j \<le> t j\<^sub>1" "t j \<le> t j\<^sub>2"
    using assms(3) *(1-2) unfolding sorted_def by auto
  then have "2 * t j \<le> t j\<^sub>1 + t j\<^sub>2" by simp
  also have "... \<le> (\<Sum>i \<in> A x. t i)" unfolding SUM by simp
  finally have "2 * t j \<le> T x" using lbrules(3) *(3) by simp
  then show ?thesis using *(3) by blast
qed

text \<open>Reasoning analogous to @{thm [source] job_lower_bound_makespan}.\<close>
lemma sorted_job_lower_bound_makespan:
  assumes "lb T A j" "j > m" "sorted j"
  shows "2 * t j \<le> makespan T"
proof -
  obtain x where x_def: "x \<in> {1..m}" "2 * t j \<le> T x"
    using sorted_job_lower_bound_machine[OF assms] ..
  with makespan_correct(1) have "T x \<le> makespan T" by blast
  with x_def(2) show ?thesis by simp
qed

lemma min_zero:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "T (min\<^sub>k T k) = 0"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using assms(2) by (simp add: Let_def)
  next
    case False
    with Suc have "T (min\<^sub>k T k) = 0" by simp
    then show ?thesis by simp
  qed
qed simp

lemma min_zero_index:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "min\<^sub>k T k \<le> x"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using min_in_range[of "Suc k"] by simp
  next
    case False
    with Suc.prems have "x \<in> {1..k}" by simp
    from min_zero[OF this, of T] assms(2) Suc.IH[OF this]
    show ?thesis by simp
  qed
qed simp

definition inv\<^sub>2 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>2 T A j = (lb T A j \<and> j \<le> n
                \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')
                \<and> (\<forall>x > j. T x = 0)
                \<and> (j \<le> m \<longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})))"

lemma inv\<^sub>2E:
  assumes "inv\<^sub>2 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
        "\<forall>x > j. T x = 0" "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  using assms unfolding inv\<^sub>2_def by blast+

lemma inv\<^sub>2I:
  assumes "lb T A j" "j \<le> n"
          "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
          "\<forall>x > j. T x = 0"
          "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  shows "inv\<^sub>2 T A j"
  unfolding inv\<^sub>2_def using assms by blast

lemma inv\<^sub>2_step:
  assumes "sorted n" "inv\<^sub>2 T A j" "j < n"
  shows "inv\<^sub>2 (T (min\<^sub>k T m := T(min\<^sub>k T m) + t(Suc j)))
              (A (min\<^sub>k T m := A(min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>2 ?T ?A _\<close>)
proof (cases \<open>Suc j > m\<close>)
  case True note invrules = inv\<^sub>2E[OF assms(2)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 3 / 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 3 / 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
      case True
      have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "2 * t (Suc j) \<le> makespan T\<^sub>1"
        using sorted_job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close> \<open>Suc j > m\<close>]
          and assms(1,3) by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  have "\<forall>x > Suc j. ?T x = 0"
    using invrules(4) min_in_range[OF m_gt_0, of T] True by simp
  with inv\<^sub>2I[OF LB _ MK] show ?thesis using assms(3) True by simp
next
  case False
  then have IN_RANGE: "Suc j \<in> {1..m}" by simp
  note invrules = inv\<^sub>2E[OF assms(2)]
  then have "T (Suc j) = 0" by blast

  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast

  \<comment> \<open>Greedy is trivially optimal\<close>
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "min\<^sub>k T m \<le> Suc j"
    using min_zero_index by blast
  with invrules(4) have EMPTY: "\<forall>x > Suc j. ?T x = 0" by simp
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "T (min\<^sub>k T m) = 0"
    using min_zero by blast
  with fun_upd_f_Max\<^sub>0[OF min_in_range[OF m_gt_0]] invrules(5) False
  have TRIV: "makespan ?T = Max\<^sub>0 (t ` {1..Suc j})" unfolding f_Max\<^sub>0_equiv[symmetric] by simp
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
    by (auto simp: TRIV[folded f_Max\<^sub>0_equiv]
            dest!: max_job_lower_bound_makespan[folded f_Max\<^sub>0_equiv])

  from inv\<^sub>2I[OF LB _ MK EMPTY TRIV] show ?thesis using assms(3) by simp
qed

lemma sorted_greedy_approximation:
"sorted n \<Longrightarrow> VARS T A i j
{True}
T := (\<lambda>_. 0);
A := (\<lambda>_. {});
j := 0;
WHILE j < n INV {inv\<^sub>2 T A j} DO
  i := min\<^sub>k T m;
  j := (Suc j);
  A := A (i := A(i) \<union> {j});
  T := T (i := T(i) + t j)
OD
{lb T A n \<and> (\<forall>T' A'. lb T' A' n \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')}"
proof (vcg, goal_cases)
  case (1 T A i j)
  then show ?case by (simp add: lb_def inv\<^sub>2_def)
next
  case (2 T A i j)
  then show ?case using inv\<^sub>2_step by simp
next
  case (3 T A i j)
  then show ?case unfolding inv\<^sub>2_def by force
qed

end (* LoadBalancing *)

end (* Theory *)


(*  Title:      HOL/Library/Option_ord.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Canonical order on option type\<close>

theory Option_ord
imports Main
begin

unbundle lattice_syntax

instantiation option :: (preorder) preorder
begin

definition less_eq_option where
  "x \<le> y \<longleftrightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> x \<le> y))"

definition less_option where
  "x < y \<longleftrightarrow> (case y of None \<Rightarrow> False | Some y \<Rightarrow> (case x of None \<Rightarrow> True | Some x \<Rightarrow> x < y))"

lemma less_eq_option_None [simp]: "None \<le> x"
  by (simp add: less_eq_option_def)

lemma less_eq_option_None_code [code]: "None \<le> x \<longleftrightarrow> True"
  by simp

lemma less_eq_option_None_is_None: "x \<le> None \<Longrightarrow> x = None"
  by (cases x) (simp_all add: less_eq_option_def)

lemma less_eq_option_Some_None [simp, code]: "Some x \<le> None \<longleftrightarrow> False"
  by (simp add: less_eq_option_def)

lemma less_eq_option_Some [simp, code]: "Some x \<le> Some y \<longleftrightarrow> x \<le> y"
  by (simp add: less_eq_option_def)

lemma less_option_None [simp, code]: "x < None \<longleftrightarrow> False"
  by (simp add: less_option_def)

lemma less_option_None_is_Some: "None < x \<Longrightarrow> \<exists>z. x = Some z"
  by (cases x) (simp_all add: less_option_def)

lemma less_option_None_Some [simp]: "None < Some x"
  by (simp add: less_option_def)

lemma less_option_None_Some_code [code]: "None < Some x \<longleftrightarrow> True"
  by simp

lemma less_option_Some [simp, code]: "Some x < Some y \<longleftrightarrow> x < y"
  by (simp add: less_option_def)

instance
  by standard
    (auto simp add: less_eq_option_def less_option_def less_le_not_le
      elim: order_trans split: option.splits)

end

instance option :: (order) order
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instance option :: (linorder) linorder
  by standard (auto simp add: less_eq_option_def less_option_def split: option.splits)

instantiation option :: (order) order_bot
begin

definition bot_option where "\<bottom> = None"

instance
  by standard (simp add: bot_option_def)

end

instantiation option :: (order_top) order_top
begin

definition top_option where "\<top> = Some \<top>"

instance
  by standard (simp add: top_option_def less_eq_option_def split: option.split)

end

instance option :: (wellorder) wellorder
proof
  fix P :: "'a option \<Rightarrow> bool"
  fix z :: "'a option"
  assume H: "\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  have "P None" by (rule H) simp
  then have P_Some [case_names Some]: "P z" if "\<And>x. z = Some x \<Longrightarrow> (P \<circ> Some) x" for z
    using \<open>P None\<close> that by (cases z) simp_all
  show "P z"
  proof (cases z rule: P_Some)
    case (Some w)
    show "(P \<circ> Some) w"
    proof (induct rule: less_induct)
      case (less x)
      have "P (Some x)"
      proof (rule H)
        fix y :: "'a option"
        assume "y < Some x"
        show "P y"
        proof (cases y rule: P_Some)
          case (Some v)
          with \<open>y < Some x\<close> have "v < x" by simp
          with less show "(P \<circ> Some) v" .
        qed
      qed
      then show ?case by simp
    qed
  qed
qed

instantiation option :: (inf) inf
begin

definition inf_option where
  "x \<sqinter> y = (case x of None \<Rightarrow> None | Some x \<Rightarrow> (case y of None \<Rightarrow> None | Some y \<Rightarrow> Some (x \<sqinter> y)))"

lemma inf_None_1 [simp, code]: "None \<sqinter> y = None"
  by (simp add: inf_option_def)

lemma inf_None_2 [simp, code]: "x \<sqinter> None = None"
  by (cases x) (simp_all add: inf_option_def)

lemma inf_Some [simp, code]: "Some x \<sqinter> Some y = Some (x \<sqinter> y)"
  by (simp add: inf_option_def)

instance ..

end

instantiation option :: (sup) sup
begin

definition sup_option where
  "x \<squnion> y = (case x of None \<Rightarrow> y | Some x' \<Rightarrow> (case y of None \<Rightarrow> x | Some y \<Rightarrow> Some (x' \<squnion> y)))"

lemma sup_None_1 [simp, code]: "None \<squnion> y = y"
  by (simp add: sup_option_def)

lemma sup_None_2 [simp, code]: "x \<squnion> None = x"
  by (cases x) (simp_all add: sup_option_def)

lemma sup_Some [simp, code]: "Some x \<squnion> Some y = Some (x \<squnion> y)"
  by (simp add: sup_option_def)

instance ..

end

instance option :: (semilattice_inf) semilattice_inf
proof
  fix x y z :: "'a option"
  show "x \<sqinter> y \<le> x"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<sqinter> y \<le> y"
    by (cases x, simp_all, cases y, simp_all)
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all)
qed

instance option :: (semilattice_sup) semilattice_sup
proof
  fix x y z :: "'a option"
  show "x \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  show "y \<le> x \<squnion> y"
    by (cases x, simp_all, cases y, simp_all)
  fix x y z :: "'a option"
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases y, simp_all, cases z, simp_all, cases x, simp_all)
qed

instance option :: (lattice) lattice ..

instance option :: (lattice) bounded_lattice_bot ..

instance option :: (bounded_lattice_top) bounded_lattice_top ..

instance option :: (bounded_lattice_top) bounded_lattice ..

instance option :: (distrib_lattice) distrib_lattice
proof
  fix x y z :: "'a option"
  show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
    by (cases x, simp_all, cases y, simp_all, cases z, simp_all add: sup_inf_distrib1 inf_commute)
qed

instantiation option :: (complete_lattice) complete_lattice
begin

definition Inf_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Sqinter>A = (if None \<in> A then None else Some (\<Sqinter>Option.these A))"

lemma None_in_Inf [simp]: "None \<in> A \<Longrightarrow> \<Sqinter>A = None"
  by (simp add: Inf_option_def)

definition Sup_option :: "'a option set \<Rightarrow> 'a option" where
  "\<Squnion>A = (if A = {} \<or> A = {None} then None else Some (\<Squnion>Option.these A))"

lemma empty_Sup [simp]: "\<Squnion>{} = None"
  by (simp add: Sup_option_def)

lemma singleton_None_Sup [simp]: "\<Squnion>{None} = None"
  by (simp add: Sup_option_def)

instance
proof
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "\<Sqinter>A \<le> x"
    by (cases x) (auto simp add: Inf_option_def in_these_eq intro: Inf_lower)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  show "z \<le> \<Sqinter>A"
  proof (cases z)
    case None then show ?thesis by simp
  next
    case (Some y)
    show ?thesis
      by (auto simp add: Inf_option_def in_these_eq Some intro!: Inf_greatest dest!: *)
  qed
next
  fix x :: "'a option" and A
  assume "x \<in> A"
  then show "x \<le> \<Squnion>A"
    by (cases x) (auto simp add: Sup_option_def in_these_eq intro: Sup_upper)
next
  fix z :: "'a option" and A
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z "
  proof (cases z)
    case None
    with * have "\<And>x. x \<in> A \<Longrightarrow> x = None" by (auto dest: less_eq_option_None_is_None)
    then have "A = {} \<or> A = {None}" by blast
    then show ?thesis by (simp add: Sup_option_def)
  next
    case (Some y)
    from * have "\<And>w. Some w \<in> A \<Longrightarrow> Some w \<le> z" .
    with Some have "\<And>w. w \<in> Option.these A \<Longrightarrow> w \<le> y"
      by (simp add: in_these_eq)
    then have "\<Squnion>Option.these A \<le> y" by (rule Sup_least)
    with Some show ?thesis by (simp add: Sup_option_def)
  qed
next
  show "\<Squnion>{} = (\<bottom>::'a option)"
    by (auto simp: bot_option_def)
  show "\<Sqinter>{} = (\<top>::'a option)"
    by (auto simp: top_option_def Inf_option_def)
qed

end

lemma Some_Inf:
  "Some (\<Sqinter>A) = \<Sqinter>(Some ` A)"
  by (auto simp add: Inf_option_def)

lemma Some_Sup:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>A) = \<Squnion>(Some ` A)"
  by (auto simp add: Sup_option_def)

lemma Some_INF:
  "Some (\<Sqinter>x\<in>A. f x) = (\<Sqinter>x\<in>A. Some (f x))"
  by (simp add: Some_Inf image_comp)

lemma Some_SUP:
  "A \<noteq> {} \<Longrightarrow> Some (\<Squnion>x\<in>A. f x) = (\<Squnion>x\<in>A. Some (f x))"
  by (simp add: Some_Sup image_comp)

lemma option_Inf_Sup: "\<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
  for A :: "('a::complete_distrib_lattice option) set set"
proof (cases "{} \<in> A")
  case True
  then show ?thesis
    by (rule INF_lower2, simp_all)
next
  case False
  from this have X: "{} \<notin> A"
    by simp
  then show ?thesis
  proof (cases "{None} \<in> A")
    case True
    then show ?thesis
      by (rule INF_lower2, simp_all)
  next
    case False

    {fix y
      assume A: "y \<in> A"
      have "Sup (y - {None}) = Sup y"
        by (metis (no_types, lifting) Sup_option_def insert_Diff_single these_insert_None these_not_empty_eq)
      from A and this have "(\<exists>z. y - {None} = z - {None} \<and> z \<in> A) \<and> \<Squnion>y = \<Squnion>(y - {None})"
        by auto
    }
    from this have A: "Sup ` A = (Sup ` {y - {None} | y. y\<in>A})"
      by (auto simp add: image_def)

    have [simp]: "\<And>y. y \<in> A \<Longrightarrow> \<exists>ya. {ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}
          = {y. \<exists>x\<in>ya - {None}. y = the x} \<and> ya \<in> A"
      by (rule exI, auto)

    have [simp]: "\<And>y. y \<in> A \<Longrightarrow>
         (\<exists>ya. y - {None} = ya - {None} \<and> ya \<in> A) \<and> \<Squnion>{ya. \<exists>x\<in>y - {None}. ya = the x}
          = \<Squnion>{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}"
      apply (safe, blast)
      by (rule arg_cong [of _ _ Sup], auto)
    {fix y
      assume [simp]: "y \<in> A"
      have "\<exists>x. (\<exists>y. x = {ya. \<exists>x\<in>y - {None}. ya = the x} \<and> y \<in> A) \<and> \<Squnion>{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x} = \<Squnion>x"
      and "\<exists>x. (\<exists>y. x = y - {None} \<and> y \<in> A) \<and> \<Squnion>{ya. \<exists>x\<in>y - {None}. ya = the x} = \<Squnion>{y. \<exists>xa. xa \<in> x \<and> (\<exists>y. xa = Some y) \<and> y = the xa}"
         apply (rule exI [of _ "{ya. \<exists>x. x \<in> y \<and> (\<exists>y. x = Some y) \<and> ya = the x}"], simp)
        by (rule exI [of _ "y - {None}"], simp)
    }
    from this have C: "(\<lambda>x.  (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A} =  (Sup ` {the ` (y - {None}) |y. y \<in> A})"
      by (simp add: image_def Option.these_def, safe, simp_all)

    have D: "\<forall> f . \<exists>Y\<in>A. f Y \<notin> Y \<Longrightarrow> False"
      by (drule spec [of _ "\<lambda> Y . SOME x . x \<in> Y"], simp add: X some_in_eq)

    define F where "F = (\<lambda> Y . SOME x::'a option . x \<in> (Y - {None}))"

    have G: "\<And> Y . Y \<in> A \<Longrightarrow> \<exists> x . x \<in> Y - {None}"
      by (metis False X all_not_in_conv insert_Diff_single these_insert_None these_not_empty_eq)

    have F: "\<And> Y . Y \<in> A \<Longrightarrow> F Y \<in> (Y - {None})"
      by (metis F_def G empty_iff some_in_eq)

    have "Some \<bottom> \<le> Inf (F ` A)"
      by (metis (no_types, lifting) Diff_iff F Inf_option_def bot.extremum image_iff
          less_eq_option_Some singletonI)

    from this have "Inf (F ` A) \<noteq> None"
      by (cases "\<Sqinter>x\<in>A. F x", simp_all)

    from this have "Inf (F ` A) \<noteq> None \<and> Inf (F ` A) \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}"
      using F by auto

    from this have "\<exists> x . x \<noteq> None \<and> x \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}"
      by blast

    from this have E:" Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {None} \<Longrightarrow> False"
      by blast

    have [simp]: "((\<Squnion>x\<in>{f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}. \<Sqinter>x) = None) = False"
      by (metis (no_types, lifting) E Sup_option_def \<open>\<exists>x. x \<noteq> None \<and> x \<in> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y}\<close>
          ex_in_conv option.simps(3))

    have B: "Option.these ((\<lambda>x. Some (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A})
        = ((\<lambda>x. (\<Squnion> Option.these x)) ` {y - {None} |y. y \<in> A})"
      by (metis image_image these_image_Some_eq)
    {
      fix f
      assume A: "\<And> Y . (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<Longrightarrow> f Y \<in> Y"

      have "\<And>xa. xa \<in> A \<Longrightarrow> f {y. \<exists>a\<in>xa - {None}. y = the a} = f (the ` (xa - {None}))"
        by  (simp add: image_def)
      from this have [simp]: "\<And>xa. xa \<in> A \<Longrightarrow> \<exists>x\<in>A. f {y. \<exists>a\<in>xa - {None}. y = the a} = f (the ` (x - {None}))"
        by blast
      have "\<And>xa. xa \<in> A \<Longrightarrow> f (the ` (xa - {None})) = f {y. \<exists>a \<in> xa - {None}. y = the a} \<and> xa \<in> A"
        by (simp add: image_def)
      from this have [simp]: "\<And>xa. xa \<in> A \<Longrightarrow> \<exists>x. f (the ` (xa - {None})) = f {y. \<exists>a\<in>x - {None}. y = the a} \<and> x \<in> A"
        by blast

      {
        fix Y
        have "Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y"
          using A [of "the ` (Y - {None})"] apply (simp add: image_def)
          using option.collapse by fastforce
      }
      from this have [simp]: "\<And> Y . Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y"
        by blast
      have [simp]: "(\<Sqinter>x\<in>A. Some (f {y. \<exists>x\<in>x - {None}. y = the x})) = \<Sqinter>{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) |x. x \<in> A}"
        by (simp add: Setcompr_eq_image)

      have [simp]: "\<exists>x. (\<exists>f. x = {y. \<exists>x\<in>A. y = f x} \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> \<Sqinter>{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) |x. x \<in> A} = \<Sqinter>x"
        apply (rule exI [of _ "{Some (f {y. \<exists>a\<in>x - {None}. y = the a}) | x . x\<in> A}"], safe)
        by (rule exI [of _ "(\<lambda> Y . Some (f (the ` (Y - {None})))) "], safe, simp_all)

      {
        fix xb
        have "xb \<in> A \<Longrightarrow> (\<Sqinter>x\<in>{{ya. \<exists>x\<in>y - {None}. ya = the x} |y. y \<in> A}. f x) \<le> f {y. \<exists>x\<in>xb - {None}. y = the x}"
          apply (rule INF_lower2 [of "{y. \<exists>x\<in>xb - {None}. y = the x}"])
          by blast+
      }
      from this have [simp]: "(\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> the (\<Sqinter>Y\<in>A. Some (f (the ` (Y - {None}))))"
        apply (simp add: Inf_option_def image_def Option.these_def)
        by (rule Inf_greatest, clarsimp)
      have [simp]: "the (\<Sqinter>Y\<in>A. Some (f (the ` (Y - {None})))) \<in> Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
        apply (auto simp add: Option.these_def)
        apply (rule imageI)
        apply auto
        using \<open>\<And>Y. Y \<in> A \<Longrightarrow> Some (f (the ` (Y - {None}))) \<in> Y\<close> apply blast
        apply (auto simp add: Some_INF [symmetric])
        done
      have "(\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> \<Squnion>Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
        by (rule Sup_upper2 [of "the (Inf ((\<lambda> Y . Some (f (the ` (Y - {None})) )) ` A))"], simp_all)
    }
    from this have X: "\<And> f . \<forall>Y. (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<longrightarrow> f Y \<in> Y \<Longrightarrow>
      (\<Sqinter>x\<in>{the ` (y - {None}) |y. y \<in> A}. f x) \<le> \<Squnion>Option.these (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
      by blast

    have [simp]: "\<And> x . x\<in>{y - {None} |y. y \<in> A} \<Longrightarrow>  x \<noteq> {} \<and> x \<noteq> {None}"
      using F by fastforce

    have "(Inf (Sup `A)) = (Inf (Sup ` {y - {None} | y. y\<in>A}))"
      by (subst A, simp)

    also have "... = (\<Sqinter>x\<in>{y - {None} |y. y \<in> A}. if x = {} \<or> x = {None} then None else Some (\<Squnion>Option.these x))"
      by (simp add: Sup_option_def)

    also have "... = (\<Sqinter>x\<in>{y - {None} |y. y \<in> A}. Some (\<Squnion>Option.these x))"
      using G by fastforce

    also have "... = Some (\<Sqinter>Option.these ((\<lambda>x. Some (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A}))"
      by (simp add: Inf_option_def, safe)

    also have "... =  Some (\<Sqinter> ((\<lambda>x.  (\<Squnion>Option.these x)) ` {y - {None} |y. y \<in> A}))"
      by (simp add: B)

    also have "... = Some (Inf (Sup ` {the ` (y - {None}) |y. y \<in> A}))"
      by (unfold C, simp)
    thm Inf_Sup
    also have "... = Some (\<Squnion>x\<in>{f ` {the ` (y - {None}) |y. y \<in> A} |f. \<forall>Y. (\<exists>y. Y = the ` (y - {None}) \<and> y \<in> A) \<longrightarrow> f Y \<in> Y}. \<Sqinter>x) "
      by (simp add: Inf_Sup)

    also have "... \<le> \<Squnion> (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
    proof (cases "\<Squnion> (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})")
      case None
      then show ?thesis by (simp add: less_eq_option_def)
    next
      case (Some a)
      then show ?thesis
        apply simp
        apply (rule Sup_least, safe)
        apply (simp add: Sup_option_def)
        apply (cases "(\<forall>f. \<exists>Y\<in>A. f Y \<notin> Y) \<or> Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {None}", simp_all)
        by (drule X, simp)
    qed
    finally show ?thesis by simp
  qed
qed

instance option :: (complete_distrib_lattice) complete_distrib_lattice
  by (standard, simp add: option_Inf_Sup)

instance option :: (complete_linorder) complete_linorder ..

unbundle no_lattice_syntax

end


section "Independent Set"

theory Approx_MIS_Hoare
imports
  "HOL-Hoare.Hoare_Logic"
  "HOL-Library.Disjoint_Sets"
begin

text \<open>The algorithm is classical, the proofs are inspired by the ones
by Berghammer and M\"uller-Olm \cite{BerghammerM03}.
In particular the approximation ratio is improved from \<open>\<Delta>+1\<close> to \<open>\<Delta>\<close>.\<close>

subsection "Graph"

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

definition independent_vertices :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
"independent_vertices E S \<longleftrightarrow> S \<subseteq> \<Union>E \<and> (\<forall>v1 v2. v1 \<in> S \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E)"

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

fun vertices :: "'a set set \<Rightarrow> 'a set" where
"vertices G = \<Union>G"

abbreviation V :: "'a set" where
"V \<equiv> vertices E"

definition approximation_miv :: "nat \<Rightarrow> 'a set \<Rightarrow> bool" where
"approximation_miv n S \<longleftrightarrow> independent_vertices E S \<and> (\<forall>S'. independent_vertices E S' \<longrightarrow> card S' \<le> card S * n)"

fun neighbors :: "'a \<Rightarrow> 'a set" where
"neighbors v = {u. {u,v} \<in> E}"

fun degree_vertex :: "'a \<Rightarrow> nat" where
"degree_vertex v = card (neighbors v)"

abbreviation \<Delta> :: nat where
"\<Delta> \<equiv> Max{degree_vertex u|u. u \<in> V}"

lemma finite_edges: "e \<in> E \<Longrightarrow> finite e"
  using card_ge_0_finite and edges2 by force

lemma finite_V: "finite V"
  using finite_edges and finite_E by auto

lemma finite_neighbors: "finite (neighbors u)"
  using finite_V and rev_finite_subset [of V "neighbors u"] by auto

lemma independent_vertices_finite: "independent_vertices E S \<Longrightarrow> finite S"
  by (metis rev_finite_subset independent_vertices_def vertices.simps finite_V)

lemma edge_ex_vertices: "e \<in> E \<Longrightarrow> \<exists>u v. u \<noteq> v \<and> e = {u, v}"
proof -
  assume "e \<in> E"
  then have "card e = Suc (Suc 0)" using edges2 by auto
  then show "\<exists>u v. u \<noteq> v \<and> e = {u, v}"
    by (metis card_eq_SucD insertI1)
qed

lemma \<Delta>_pos [simp]: "E = {} \<or> 0 < \<Delta>"
proof cases
  assume "E = {}"
  then show "E = {} \<or> 0 < \<Delta>" by auto
next
  assume 1: "E \<noteq> {}"
  then have "V \<noteq> {}" using edges2 by fastforce
  moreover have "finite {degree_vertex u |u. u \<in> V}"
    by (metis finite_V finite_imageI Setcompr_eq_image)
  ultimately have 2: "\<Delta> \<in> {degree_vertex u |u. u \<in> V}" using Max_in by auto
  have "\<Delta> \<noteq> 0"
  proof
    assume "\<Delta> = 0"
    with 2 obtain u where 3: "u \<in> V" and 4: "degree_vertex u = 0" by auto
    from 3 obtain e where 5: "e \<in> E" and "u \<in> e" by auto
    moreover with 4 have "\<forall>v. {u, v} \<noteq> e" using finite_neighbors insert_absorb by fastforce
    ultimately show False using edge_ex_vertices by auto
  qed
  then show "E = {} \<or> 0 < \<Delta>" by auto
qed

lemma \<Delta>_max_degree: "u \<in> V \<Longrightarrow> degree_vertex u \<le> \<Delta>"
proof -
  assume H: "u \<in> V"
  have "finite {degree_vertex u |u. u \<in> V}"
    by (metis finite_V finite_imageI Setcompr_eq_image)
  with H show "degree_vertex u \<le> \<Delta>" using Max_ge by auto
qed

subsection \<open>Wei's algorithm: \<open>(\<Delta>+1)\<close>-approximation\<close>

text \<open>The 'functional' part of the invariant, used to prove that the algorithm produces an independent set of vertices.\<close>

definition inv_iv :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"inv_iv S X \<longleftrightarrow> independent_vertices E S
            \<and> X \<subseteq> V
            \<and> (\<forall>v1 \<in> (V - X). \<forall>v2 \<in> S. {v1, v2} \<notin> E)
            \<and> S \<subseteq> X"

text \<open>Strenghten the invariant with an approximation ratio \<open>r\<close>:\<close>

definition inv_approx :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> bool" where
"inv_approx S X r \<longleftrightarrow> inv_iv S X \<and> card X \<le> card S * r"

text \<open>Preservation of the functional invariant:\<close>

lemma inv_preserv:
  fixes S :: "'a set"
    and X :: "'a set"
    and x :: "'a"
  assumes inv: "inv_iv S X"
      and x_def: "x \<in> V - X"
    shows "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
proof -
  have inv1: "independent_vertices E S"
   and inv2: "X \<subseteq> V"
   and inv3: "S \<subseteq> X"
   and inv4: "\<forall>v1 v2. v1 \<in> (V - X) \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E"
    using inv unfolding inv_iv_def by auto
  have finite_S: "finite S" using inv1 and independent_vertices_finite by auto
  have S1: "\<forall>y \<in> S. {x, y} \<notin> E" using inv4 and x_def by blast
  have S2: "\<forall>x \<in> S. \<forall>y \<in> S. {x, y} \<notin> E" using inv1 unfolding independent_vertices_def by metis
  have S3: "v1 \<in> insert x S \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
    proof -
      assume "v1 \<in> insert x S" and "v2 \<in> insert x S"
      then consider
          (a) "v1 = x" and "v2 = x"
        | (b) "v1 = x" and "v2 \<in> S"
        | (c) "v1 \<in> S" and "v2 = x"
        | (d) "v1 \<in> S" and "v2 \<in> S"
        by auto
      then show "{v1, v2} \<notin> E"
      proof cases
        case a then show ?thesis using edges2 by force
      next
        case b then show ?thesis using S1 by auto
      next
        case c then show ?thesis using S1 by (metis doubleton_eq_iff)
      next
        case d then show ?thesis using S2 by auto
      qed
    qed
  (* invariant conjunct 1 *)
  have "independent_vertices E (insert x S)"
    using S3 and inv1 and x_def unfolding independent_vertices_def by auto
  (* invariant conjunct 2 *)
  moreover have "X \<union> neighbors x \<union> {x} \<subseteq> V"
  proof
    fix xa
    assume "xa \<in> X \<union> neighbors x \<union> {x}"
    then consider (a) "xa \<in> X" | (b) "xa \<in> neighbors x" | (c) "xa = x" by auto
    then show "xa \<in> V"
    proof cases
      case a
      then show ?thesis using inv2 by blast
    next
      case b
      then show ?thesis by auto
    next
      case c
      then show ?thesis using x_def by blast
    qed
  qed
  (* invariant conjunct 3 *)
  moreover have "insert x S \<subseteq> X \<union> neighbors x \<union> {x}" using inv3 by auto
  (* invariant conjunct 4 *)
  moreover have "v1 \<in> V - (X \<union> neighbors x \<union> {x}) \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
  proof -
    assume H: "v1 \<in> V - (X \<union> neighbors x \<union> {x})" and "v2 \<in> insert x S"
    then consider (a) "v2 = x" | (b) "v2 \<in> S" by auto
    then show "{v1, v2} \<notin> E"
    proof cases
      case a
      with H have "v1 \<notin> neighbors v2" by blast
      then show ?thesis by auto
    next
      case b
      from H have "v1 \<in> V - X" by blast
      with b and inv4 show ?thesis by blast
    qed
  qed
  (* conclusion *)
  ultimately show "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})" unfolding inv_iv_def by blast
qed

lemma inv_approx_preserv:
  assumes inv: "inv_approx S X (\<Delta> + 1)"
      and x_def: "x \<in> V - X"
    shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite
    unfolding inv_approx_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_approx_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* the approximation ratio is preserved (at most \<Delta>+1 vertices are removed in any iteration) *)
  moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * (\<Delta> + 1)"
  proof -
    have "degree_vertex x \<le> \<Delta>" using \<Delta>_max_degree and x_def by auto
    then have "card (neighbors x \<union> {x}) \<le> \<Delta> + 1" using card_Un_le [of "neighbors x" "{x}"] by auto
    then have "card (X \<union> neighbors x \<union> {x}) \<le> card X + \<Delta> + 1" using card_Un_le [of X "neighbors x \<union> {x}"] by auto
    also have "... \<le> card S * (\<Delta> + 1) + \<Delta> + 1" using inv unfolding inv_approx_def by auto
    also have "... = card (insert x S) * (\<Delta> + 1)" using finite_S and Sx by auto
    finally show ?thesis .
  qed
  (* conclusion *)
  ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
    unfolding inv_approx_def by auto
qed

(* the antecedent combines inv_approx (for an arbitrary ratio r) and the negated post-condition *)
lemma inv_approx: "independent_vertices E S \<Longrightarrow> card V \<le> card S * r \<Longrightarrow> approximation_miv r S"
proof -
  assume 1: "independent_vertices E S" and 2: "card V \<le> card S * r"
  have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * r" for S'
  proof -
    assume  "independent_vertices E S'"
    then have "S' \<subseteq> V" unfolding independent_vertices_def by auto
    then have "card S' \<le> card V" using finite_V and card_mono by auto
    also have "... \<le> card S * r" using 2 by auto
    finally show "card S' \<le> card S * r" .
  qed
  with 1 show "approximation_miv r S" unfolding approximation_miv_def by auto
qed

theorem wei_approx_\<Delta>_plus_1:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
  { True }
  S := {};
  X := {};
  WHILE X \<noteq> V
  INV { inv_approx S X (\<Delta> + 1) }
  DO x := (SOME x. x \<in> V - X);
     S := insert x S;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv (\<Delta> + 1) S }"
proof (vcg, goal_cases)
  case (1 S X x) (* invariant initially true *)
  then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
next
  case (2 S X x) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X)"
  have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
  then have "?x \<in> V - X" using some_in_eq by metis
  with 2 show ?case using inv_approx_preserv by auto
next
  case (3 S X x) (* invariant implies post-condition *)
  then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
qed

subsection \<open>Wei's algorithm: \<open>\<Delta>\<close>-approximation\<close>

text \<open>The previous approximation uses very little information about the optimal solution (it has at most as many vertices as the set itself). With some extra effort we can improve the ratio to \<open>\<Delta>\<close> instead of \<open>\<Delta>+1\<close>. In order to do that we must show that among the vertices removed in each iteration, at most \<open>\<Delta>\<close> could belong to an optimal solution. This requires carrying around a set \<open>P\<close> (via a ghost variable) which records the vertices deleted in each iteration.\<close>

definition inv_partition :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
"inv_partition S X P \<longleftrightarrow> inv_iv S X
                     \<and> \<Union>P = X
                     \<and> (\<forall>p \<in> P. \<exists>s \<in> V. p = {s} \<union> neighbors s)
                     \<and> card P = card S
                     \<and> finite P"

lemma inv_partition_preserv:
  assumes inv: "inv_partition S X P"
      and x_def: "x \<in> V - X"
    shows "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite
    unfolding inv_partition_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_partition_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_partition_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* conjunct 1 *)
  moreover have "\<Union>(insert ({x} \<union> neighbors x) P) = X \<union> neighbors x \<union> {x}"
    using inv unfolding inv_partition_def by auto
  (* conjunct 2 *)
  moreover have "(\<forall>p\<in>insert ({x} \<union> neighbors x) P. \<exists>s \<in> V. p = {s} \<union> neighbors s)"
    using inv and x_def unfolding inv_partition_def by auto
  (* conjunct 3 *)
  moreover have "card (insert ({x} \<union> neighbors x) P) = card (insert x S)"
  proof -
    from x_def and inv have "x \<notin> \<Union>P" unfolding inv_partition_def by auto
    then have "{x} \<union> neighbors x \<notin> P" by auto
    then have "card (insert ({x} \<union> neighbors x) P) = card P + 1" using inv unfolding inv_partition_def by auto
    moreover have "card (insert x S) = card S + 1" using Sx and finite_S by auto
    ultimately show ?thesis using inv unfolding inv_partition_def by auto
  qed
  (* conjunct 4 *)
  moreover have "finite (insert ({x} \<union> neighbors x) P)"
    using inv unfolding inv_partition_def by auto
  (* conclusion *)
  ultimately show "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
    unfolding inv_partition_def by auto
qed

lemma card_Union_le_sum_card:
  fixes U :: "'a set set"
  assumes "\<forall>u \<in> U. finite u"
  shows "card (\<Union>U) \<le> sum card U"
proof (cases "finite U")
  case False
  then show "card (\<Union>U) \<le> sum card U"
    using card_eq_0_iff finite_UnionD by auto
next
  case True
  then show "card (\<Union>U) \<le> sum card U"
  proof (induct U rule: finite_induct)
    case empty
    then show ?case by auto
  next
    case (insert x F)
    then have "card(\<Union>(insert x F)) \<le> card(x) + card (\<Union>F)" using card_Un_le by auto
    also have "... \<le> card(x) + sum card F" using insert.hyps by auto
    also have "... = sum card (insert x F)" using sum.insert_if and insert.hyps by auto
    finally show ?case .
  qed
qed

(* this lemma could be more generally about U :: "nat set", but this makes its application more difficult later *)
lemma sum_card:
  fixes U :: "'a set set"
    and n :: nat
  assumes "\<forall>S \<in> U. card S \<le> n"
  shows "sum card U \<le> card U * n"
proof cases
  assume "infinite U \<or> U = {}"
  then have "sum card U = 0" using sum.infinite by auto
  then show "sum card U \<le> card U * n" by auto
next
  assume "\<not>(infinite U \<or> U = {})"
  with assms have "finite U" and "U \<noteq> {}"and "\<forall>S \<in> U. card S \<le> n" by auto
  then show "sum card U \<le> card U * n"
  proof (induct U rule: finite_ne_induct)
    case (singleton x)
    then show ?case by auto
  next
    case (insert x F)
    assume "\<forall>S\<in>insert x F. card S \<le> n"
    then have 1:"card x \<le> n" and 2:"sum card F \<le> card F * n" using insert.hyps by auto
    then have "sum card (insert x F) = card x + sum card F" using sum.insert_if and insert.hyps by auto
    also have "... \<le> n + card F * n" using 1 and 2 by auto
    also have "... = card (insert x F) * n" using card_insert_if and insert.hyps by auto
    finally show ?case .
  qed
qed

(* among the vertices deleted in each iteration, at most \<Delta> can belong to an independent set of
   vertices: the chosen vertex or (some of) its neighbors *)
lemma x_or_neighbors:
  fixes P :: "'a set set"
    and S :: "'a set"
  assumes inv: "\<forall>p\<in>P. \<exists>s \<in> V. p = {s} \<union> neighbors s"
      and ivS: "independent_vertices E S"
    shows "\<forall>p \<in> P. card (S \<inter> p) \<le> \<Delta>"
proof
  fix p
  assume "p \<in> P"
  then obtain s where 1: "s \<in> V \<and> p = {s} \<union> neighbors s" using inv by blast
  then show "card (S \<inter> p) \<le> \<Delta>"
  proof cases
    assume "s \<in> S"
    then have "S \<inter> neighbors s = {}" using ivS unfolding independent_vertices_def by auto
    then have "S \<inter> p \<subseteq> {s}" using 1 by auto
    then have 2: "card (S \<inter> p) \<le> 1" using subset_singletonD by fastforce
    consider (a) "E = {}" | (b) "0 < \<Delta>" using \<Delta>_pos by auto
    then show "card (S \<inter> p) \<le> \<Delta>"
    proof cases
      case a
      then have "S = {}" using ivS unfolding independent_vertices_def by auto
      then show ?thesis by auto
    next
      case b
      then show ?thesis using 2 by auto
    qed
  next
    assume "s \<notin> S"
    with 1 have "S \<inter> p \<subseteq> neighbors s" by auto
    then have "card (S \<inter> p) \<le> degree_vertex s" using card_mono and finite_neighbors by auto
    then show "card (S \<inter> p) \<le> \<Delta>" using 1 and \<Delta>_max_degree [of s] by auto
  qed
qed

(* the premise combines the invariant and the negated post-condition *)
lemma inv_partition_approx: "inv_partition S V P \<Longrightarrow> approximation_miv \<Delta> S"
proof -
  assume H1: "inv_partition S V P"
  then have "independent_vertices E S" unfolding inv_partition_def inv_iv_def by auto
  moreover have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * \<Delta>" for S'
  proof -
    let ?I = "{S' \<inter> p | p. p \<in> P}"
    (* split the optimal solution among the sets of P, which cover V so no element is
       lost. We obtain a cover of S' and show the required bound on its cardinality *)
    assume H2: "independent_vertices E S'"
    then have "S' \<subseteq> V" unfolding independent_vertices_def using vertices.simps by blast
    with H1 have "S' = S' \<inter> \<Union>P" unfolding inv_partition_def by auto
    then have "S' = (\<Union>p \<in> P. S' \<inter> p)" using Int_Union by auto
    then have "S' = \<Union>?I" by blast
    moreover have "finite S'" using H2 and independent_vertices_finite by auto
    then have "p \<in> P \<Longrightarrow> finite (S' \<inter> p)" for p by auto
    ultimately have "card S' \<le> sum card ?I" using card_Union_le_sum_card [of ?I] by auto
    also have "... \<le> card ?I * \<Delta>"
      using x_or_neighbors [of P S']
        and sum_card [of ?I \<Delta>]
        and H1 and H2 unfolding inv_partition_def by auto
    also have "... \<le> card P * \<Delta>"
    proof -
      have "finite P" using H1 unfolding inv_partition_def by auto
      then have "card ?I \<le> card P"
        using Setcompr_eq_image [of "\<lambda>p. S' \<inter> p" P]
          and card_image_le unfolding inv_partition_def by auto
      then show ?thesis by auto
    qed
    also have "... = card S * \<Delta>" using H1 unfolding inv_partition_def by auto
    ultimately show "card S' \<le> card S * \<Delta>" by auto
  qed
  ultimately show "approximation_miv \<Delta> S" unfolding approximation_miv_def by auto
qed

theorem wei_approx_\<Delta>:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
  { True }
  S := {};
  X := {};
  WHILE X \<noteq> V
  INV { \<exists>P. inv_partition S X P }
  DO x := (SOME x. x \<in> V - X);
     S := insert x S;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv \<Delta> S }"
proof (vcg, goal_cases)
  case (1 S X x) (* invariant initially true *)
  (* the invariant is initially true with the ghost variable P := {} *)
  have "inv_partition {} {} {}" unfolding inv_partition_def inv_iv_def independent_vertices_def by auto
  then show ?case by auto
next
  case (2 S X x) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X)"
  from 2 obtain P where I: "inv_partition S X P" by auto
  then have "V - X \<noteq> {}" using 2 unfolding inv_partition_def by auto
  then have "?x \<in> V - X" using some_in_eq by metis
  (* show that the invariant is true with the ghost variable P := insert ({?x} \<union> neighbors ?x) P *)
  with I have "inv_partition (insert ?x S) (X \<union> neighbors ?x \<union> {?x}) (insert ({?x} \<union> neighbors ?x) P)"
    using inv_partition_preserv by blast
  then show ?case by auto
next
  case (3 S X x) (* invariant implies post-condition *)
  then show ?case using inv_partition_approx unfolding inv_approx_def by auto
qed

subsection "Wei's algorithm with dynamically computed approximation ratio"

text \<open>In this subsection, we augment the algorithm with a variable used to compute the effective approximation ratio of the solution. In addition, the vertex of smallest degree is picked. With this heuristic, the algorithm achieves an approximation ratio of \<open>(\<Delta>+2)/3\<close>, but this is not proved here.\<close>

definition vertex_heuristic :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"vertex_heuristic X v = (\<forall>u \<in> V - X. card (neighbors v - X) \<le> card (neighbors u - X))"

(* this lemma is needed to show that there exist a vertex to be picked by the heuristic *)
lemma ex_min_finite_set:
  fixes S :: "'a set"
    and f :: "'a \<Rightarrow> nat"
    shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> S \<and> (\<forall>y \<in> S. f x \<le> f y)"
          (is "?P1 \<Longrightarrow> ?P2 \<Longrightarrow> \<exists>x. ?minf S x")
proof (induct S rule: finite_ne_induct)
  case (singleton x)
  have "?minf {x} x" by auto
  then show ?case by auto
next
  case (insert x F)
  from insert(4) obtain y where Py: "?minf F y" by auto
  show "\<exists>z. ?minf (insert x F) z"
  proof cases
    assume "f x < f y"
    then have "?minf (insert x F) x" using Py by auto
    then show ?case by auto
  next
    assume "\<not>f x < f y"
    then have "?minf (insert x F) y" using Py by auto
    then show ?case by auto
  qed
qed

lemma inv_approx_preserv2:
  fixes S :: "'a set"
    and X :: "'a set"
    and s :: nat
    and x :: "'a"
  assumes inv: "inv_approx S X s"
      and x_def: "x \<in> V - X"
    shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite unfolding inv_approx_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_approx_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* the approximation ratio is preserved *)
  moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * max (card (neighbors x \<union> {x} - X)) s"
  proof -
    let ?N = "neighbors x \<union> {x} - X"
    have "card (X \<union> ?N) \<le> card X + card ?N" using card_Un_le [of X ?N] by auto
    also have "... \<le> card S * s + card ?N" using inv unfolding inv_approx_def by auto
    also have "... \<le> card S * max (card ?N) s + card ?N" by auto
    also have "... \<le> card S * max (card ?N) s + max (card ?N) s" by auto
    also have "... = card (insert x S) * max (card ?N) s" using Sx and finite_S by auto
    finally show ?thesis by auto
  qed
  (* conclusion *)
  ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
    unfolding inv_approx_def by auto
qed

theorem wei_approx_min_degree_heuristic:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a) (r :: nat)
  { True }
  S := {};
  X := {};
  r := 0;
  WHILE X \<noteq> V
  INV { inv_approx S X r }
  DO x := (SOME x. x \<in> V - X \<and> vertex_heuristic X x);
     S := insert x S;
     r := max (card (neighbors x \<union> {x} - X)) r;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv r S }"
proof (vcg, goal_cases)
  case (1 S X x r) (* invariant initially true *)
  then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
next
  case (2 S X x r) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X \<and> vertex_heuristic X x)"
  have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
  moreover have "finite (V - X)" using 2 and finite_V by auto
  ultimately have "\<exists>x. x \<in> V - X \<and> vertex_heuristic X x"
    using ex_min_finite_set [where ?f = "\<lambda>x. card (neighbors x - X)"]
    unfolding vertex_heuristic_def by auto
  then have x_def: "?x \<in> V - X \<and> vertex_heuristic X ?x"
    using someI_ex [where ?P = "\<lambda>x. x \<in> V - X \<and> vertex_heuristic X x"] by auto
  with 2 show ?case using inv_approx_preserv2 by auto
next
  case (3 S X x r)
  then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
qed

end
end