theory LoadBalancing imports Complex_Main Groups_List "HOL-Library.Multiset"
begin

section \<open>The algorithm\<close>

text \<open>This job scheduling function takes a list of job execution times and uses it
      to mutate the schedule. The proofs about optimal upper bounds will assume that the function
      is called with an empty schedule, i.e., 'replicate m {#}',
      where 'm' stands for the number of machines available.

      The first element of the job list is scheduled last.\<close>

definition add_job :: "nat \<Rightarrow> (nat multiset) list \<Rightarrow> (nat multiset) list" where
  "add_job n ms \<equiv>  add_mset n (hd ms)#(tl ms)"

fun balance :: "nat list \<Rightarrow> (nat multiset) list \<Rightarrow> (nat multiset) list" where
"balance []     = id" |
"balance (t#ts) = add_job t \<circ> sort_key sum_mset \<circ> balance ts"

text \<open>Test cases\<close>
(* Figure 11.1 in KT*)
value \<open>balance (rev [2,3,4,6,2,2]) (replicate 3 {#})\<close>

section \<open>Some useful properties\<close>

subsection \<open>Valid schedules\<close>

text \<open>For each machine, we keep a set of assigned jobs represented as their execution times.
      The algorithm assumes that the jobs are always placed on the machine with the smallest load.
      We implement this assumption by sorting the list of machines by their load before placing jobs.
      The head of the sorted list will therefore have the smallest load.\<close>

definition schedule :: "nat list \<Rightarrow> (nat multiset) list \<Rightarrow> bool" where
  "schedule ts ms \<equiv> \<Union># (mset ms) = mset ts"

theorem loads_eq_times:
  fixes ms::"(nat multiset) list"
  assumes
    msch: "schedule ts ms"
  shows "sum_list (map sum_mset ms) = sum_list ts"
proof -
  have "sum_list (map sum_mset ms) = sum_mset (\<Union># (mset ms))" by (induction ms) simp_all
  also have "\<dots> = sum_mset (mset ts)" using msch schedule_def by simp
  also have "\<dots> = sum_list ts" by (simp add: sum_mset_sum_list)
  finally show ?thesis .
qed

lemma balance_length:
  assumes "length ms > 0"
  shows "length ms = length (balance ts ms)"
(* Suc_pred fails to apply in this:
  using assms add_job_def by (induction ts) simp_all *)
proof (induction ts)
  case Nil
  then show ?case by simp
next
  case (Cons t ts)
  then show ?case using assms add_job_def by simp
qed

lemma mset_add_job:
  assumes "length ms > 0"
  shows "\<Union># (mset (add_job n ms)) = add_mset n (\<Union># (mset ms))"
  using assms add_job_def by (induction ms) simp_all

theorem schedule_balance:
  assumes "m > 0"
  shows "schedule ts (balance ts (replicate m {#}))"
proof (induction ts)
  case Nil
  then show ?case using schedule_def by simp
next
  case (Cons a ts)
  have "length (balance ts (replicate m {#})) > 0" using assms balance_length by simp
  thus ?case using schedule_def mset_add_job
    by (metis (no_types, lifting) balance.simps(2) length_sort Cons mset.simps(2) mset_sort o_def)
qed

subsection \<open>The last job contributing to the makespan\<close>

definition makespan :: "(nat multiset) list \<Rightarrow> nat" where
  "makespan ms \<equiv> Max (set (map sum_mset ms))"

definition premakespan :: "(nat multiset) list \<Rightarrow> nat" where
  "premakespan ms \<equiv> Min (set (map sum_mset ms))"

lemma balance_append: "balance (xs @ ys) ms = balance xs (balance ys ms)"
  by (induction xs arbitrary:ys) simp_all

lemma balance_split: "balance ts ms = balance (take n ts) (balance (drop n ts) ms)"
  using append_take_drop_id balance_append by metis

lemma premakespan_mono:
  assumes "t > 0"  and "length ms > 0"
  shows "premakespan (balance (t#ts) ms) \<ge> premakespan (balance ts ms)"
    (is "premakespan (balance (t#ts) ms) \<ge> premakespan ?btm")
proof -
  have "sum_mset (add_mset t (hd (sort_key sum_mset ?btm)))
        \<ge> sum_mset (hd (sort_key sum_mset ?btm))" by simp
  moreover have "min (sum_mset (add_mset t (hd (sort_key sum_mset ?btm))))
                  (Min (set (map sum_mset (tl (sort_key sum_mset ?btm)))))
        \<ge> min (sum_mset (hd (sort_key sum_mset ?btm)))
                   (Min (set (map sum_mset (tl (sort_key sum_mset ?btm)))))" by simp
  ultimately have "Min (insert (sum_mset (add_mset t (hd (sort_key sum_mset ?btm))))
                  (set (map sum_mset (tl (sort_key sum_mset ?btm)))))
        \<ge> Min (insert (sum_mset (hd (sort_key sum_mset ?btm)))
                   (set (map sum_mset (tl (sort_key sum_mset ?btm)))))"
    by (metis List.finite_set Min_insert Min_insert2 empty_iff)
  hence "Min (set (map sum_mset (add_mset t (hd (sort_key sum_mset ?btm))
                               #(tl (sort_key sum_mset ?btm)))))
        \<ge> Min (set (map sum_mset ((hd (sort_key sum_mset ?btm))
                               #(tl (sort_key sum_mset ?btm)))))"
    by (simp add: premakespan_def)
  thus ?thesis using add_job_def premakespan_def balance_length assms
    by (metis balance.simps(2) comp_apply length_sort list.collapse list.size(3)
        not_less_zero set_map set_sort)
qed

lemma premakespan_balance_drop:
  assumes
    mlen: "length ms > 0" and
    tpos: "\<forall> t. t \<in> set xs \<longrightarrow> t > 0"
  shows "premakespan (balance (xs@ys) ms) \<ge> premakespan (balance ys ms)"
proof -
  show ?thesis using tpos
  proof (induction xs)
    case Nil
    then show ?case by simp
  next
    case (Cons a as)
    have "premakespan (balance as ms) \<le> premakespan (balance (a # as) ms)"
      using premakespan_mono mlen by (simp add: Cons.prems balance_append)
    hence "premakespan (balance (a # (as @ ys)) ms) \<ge> premakespan (balance ys ms)"
      using balance_append balance_length premakespan_mono mlen Cons
      by (metis insert_iff list.simps(15) order_trans)
    thus ?case by simp
  qed
qed

section \<open>Some general lemmas\<close>

lemma mult_max_ge_sum_list:
  assumes "x = Max (set xs)"
  shows "length xs * x \<ge> sum_list xs"
proof -
  have "\<forall>y. y \<in> set xs \<longrightarrow> id y \<le> (\<lambda>_. x) y" using assms by simp
  hence "sum_list (replicate (length xs) x) \<ge> sum_list xs"
    using sum_list_mono
    by (metis id_apply list.map_id0 map_replicate_const)
  moreover have "length xs * x = sum_list (replicate (length xs) x)" by (induction xs) simp_all
  ultimately show ?thesis by simp
qed

lemma mult_min_le_sum_list:
  assumes "x = Min (set xs)"
  shows "length xs * x \<le> sum_list xs"
proof -
  have "\<forall>y. y \<in> set xs \<longrightarrow> id y \<ge> (\<lambda>_. x) y" using assms by simp
  hence "sum_list (replicate (length xs) x) \<le> sum_list xs"
    using sum_list_mono
    by (metis id_apply list.map_id0 map_replicate_const)
  moreover have "length xs * x = sum_list (replicate (length xs) x)" by (induction xs) simp_all
  ultimately show ?thesis by simp
qed

lemma mult_size_sum_mset: "sum_mset xs \<ge> size xs * Min_mset xs"
  by (metis (no_types) mult_min_le_sum_list mset_sorted_list_of_multiset
      set_sorted_list_of_multiset size_mset sum_mset_sum_list)

lemma sum_mset_mult_size:
  assumes "\<forall>x. x \<in># xs \<longrightarrow> x > 0" and "\<forall>x. x \<in># xs \<longrightarrow> x \<ge> a"
  shows "sum_mset xs \<ge> size xs * a"
  using assms
  by (metis Min_in finite_set_mset mult_not_zero nat_mult_le_cancel_disj order_trans
      set_mset_eq_empty_iff size_empty mult_size_sum_mset)

lemma size_Union_mset: "size (\<Union># (mset xs)) = sum_list (map size xs)"
  by (induction xs) simp_all

lemma sum_mset_subset_eq:
  fixes M N :: "('a :: ordered_cancel_comm_monoid_diff) multiset"
  shows "M \<subseteq># N \<Longrightarrow> sum_mset M \<le> sum_mset N"
  by (metis le_iff_add mset_subset_eq_exists_conv sum_mset.union)

lemma sum_mset_plus:
  fixes x y :: nat
  shows "sum_mset (mset [x, y]) = x + y"
  by simp

lemma pair_in_mset:
  assumes "x \<noteq> y" and "x \<in># A" and "y \<in># A"
  shows "mset [x, y] \<subseteq># A"
  using assms by (metis insert_DiffM insert_noteq_member mset.simps(1) mset.simps(2)
      mset_subset_eq_add_mset_cancel single_subset_iff)

lemma sum_mset_replicate:
  assumes "replicate_mset n x \<subseteq># A"
  shows "n * x \<le> sum_mset A"
  using assms sum_mset_subset_eq by fastforce

lemma mset_replicate:
  shows "mset (replicate n x) = replicate_mset n x"
  by (induction n) simp_all

section \<open>Time bounds\<close>

text \<open>If the makespan computed by 'balance' is smaller
      than the makespan of any schedule by some constant factor,
      it includes the optimal makespan.

      Therefore, we do not need to specify explicitly that the optimal makespan
      is the minimal one of all possible makespans.

      Otherwise, we follow the textbook proof by Kleinberg and Tardos, mostly.
      For simplicity, we avoid reasoning about reals.\<close>

lemma makespan_ge_avg: (* Lemma 11.1 in KT *)
  fixes ms::"(nat multiset) list"
  assumes "schedule ts ms" and "length ms > 0"
  shows "length ms * makespan ms \<ge> sum_list ts"
  using assms makespan_def loads_eq_times
  by (metis length_map mult_max_ge_sum_list)

text \<open>The textbook proof employs reasoning about array indices which is cumbersome to formalize.
      Encoding the index 'j' used in the textbook proof to denote the last job placed on a machine
      that attains the makespan is particularly difficult.

      We keep ourselves to reasoning about lists instead.
      To that end, we define the list of jobs 'ts' as a concatenation of two lists 'us' and 'vs',
      where the second list is non-empty and contains jobs 1..j.
      The length of 'vs' is equal to 'j', and we encode this idea with the 'j_def' assumption.
      The head of 'vs' corresponds to 't_j' in the textbook proof.

      By observation made in the first paragraph of the textbook proof of Theorem 11.3,
      a makespan is attained after placing a job on a machine with the _smallest_ load.
      We define that load as 'premakespan'.

      Thus, 'j_def' should be understood as follows: the last job contributing to the makespan
      is the head element of some suffix of the job list for which a makespan is computed
      that is equal to the makespan for the unmodified job list.

      The elements of 'us' are placed on other machines and do not contribute to makespan.
      Lemma 'premakespan_balance_drop' contains the proof of this fact.

      It is possible, indeed, to rewrite the proof without defining 'ts' as a concatenation
      of lists by using 'take' and 'drop' as needed, but such a proof would turn out _less_ readable
      and more difficult to maintain.\<close>

lemma balance_optimal_common:
  fixes ms::"(nat multiset) list"
  assumes
    mpos:    "m > 0" and
    mrep:    "ms = replicate m {#}" and
    ts_def:  "ts = us@vs \<and> length vs > 0 \<and> (\<forall> t. t \<in> set ts \<longrightarrow> t > 0)" and
    mos_def: "schedule ts mos \<and> length mos = m" and
    topt:    "Topt = makespan mos" and
    T_def:   "T = makespan (balance ts ms)" and
    j_def:   "T = hd vs + premakespan (balance (tl vs) ms)"
  shows "T - hd vs \<le> Topt"
proof -
  have "premakespan (balance (tl vs) ms) \<le> premakespan (balance vs ms)"
    using premakespan_mono ts_def mpos mrep
    by (metis in_set_conv_decomp length_replicate less_irrefl list.exhaust_sel list.size(3))
  hence "T - hd vs \<le> premakespan (balance ts ms)"
    using premakespan_balance_drop ts_def T_def j_def mpos mrep
    by (metis Un_iff add_diff_cancel_left' length_replicate order_trans set_append)
  moreover have "length (balance ts ms) = m" using mpos mrep balance_length by simp
  ultimately have  "m * (T - hd vs) \<le> sum_list (map sum_mset (balance ts ms))"
    using premakespan_def mpos
    by (metis mult_min_le_sum_list length_map nat_mult_le_cancel_disj order_trans)
  hence "m * (T - hd vs) \<le> sum_list ts"
    using schedule_balance loads_eq_times mpos mrep by metis
  hence "m * (T - hd vs) \<le> m * Topt"
    using makespan_ge_avg mos_def topt order_trans by fastforce
  thus ?thesis using mpos by simp
qed

subsection \<open>Greedy-Balance\<close>

lemma makespan_ge_t: (* Lemma 11.2 in KT *)
  fixes ms::"(nat multiset) list"
  assumes msch: "schedule ts ms"
  shows "t \<in> set ts \<longrightarrow> makespan ms \<ge> t"
proof -
  have "t \<in> set ts \<longrightarrow> (\<exists>m. m \<in> set ms \<and> t \<in># m)"
    using schedule_def msch by (metis in_Union_mset_iff set_mset_mset)
  then obtain m where t_in_m: "t \<in> set ts \<longrightarrow> (m \<in> set ms \<and> t \<in># m)" by auto
  hence "t \<in> set ts \<longrightarrow> t \<le> sum_mset m" using sum_mset.remove by fastforce
  moreover have "m \<in> set ms \<longrightarrow> makespan ms \<ge> sum_mset m" using makespan_def by simp
  ultimately show ?thesis using t_in_m order_trans by fastforce
qed

theorem greedy_balance_optimal: (* Theorem 11.3 in KT *)
  assumes
    mpos:    "m > 0" and
    mrep:    "ms = replicate m {#}" and
    ts_def:  "ts = us@vs \<and> length vs > 0 \<and> (\<forall> t. t \<in> set ts \<longrightarrow> t > 0)" and
    mos_def: "schedule ts mos \<and> length mos = m" and
    topt:    "Topt = makespan mos" and
    T_def:   "T = makespan (balance ts ms)" and
    j_def:   "T = hd vs + premakespan (balance (tl vs) ms)"
  shows "T \<le> 2 * Topt"
proof -
  have "hd vs \<in> set ts" using ts_def by simp
  hence "T - hd vs + hd vs \<le> 2 * Topt"
    using balance_optimal_common makespan_ge_t assms by (metis add_mono mult_2)
  thus  ?thesis by linarith
qed

subsection \<open>Sorted-Balance\<close>

text \<open>Note that 'balance' schedules jobs starting from the end of the job list.
      Its head is scheduled last. Therefore, it must be sorted in the _increasing_ order.\<close>

lemma makespan_ge_2t: (* Lemma 11.4 in KT*)
  fixes ms::"(nat multiset) list"
  assumes
    ts_def:  "ts = us@vs \<and> length vs > 0 \<and> (\<forall> t. t \<in> set ts \<longrightarrow> t > 0)" and
    msch: "schedule ts ms" and
    ms_le_ts: "vs = qs@rs \<and> length qs > 0 \<and> length rs = length ms" and
    ts_sorted: "sorted ts" and
    opt_greedy: "\<forall>m. m \<in> set ms \<longrightarrow> (\<exists>u. u \<in> set rs \<and> u \<in># m)"
  shows "t \<in> set qs \<longrightarrow> makespan ms \<ge> 2 * t"
proof -
  have "t \<in> set qs \<longrightarrow> (\<exists>m. m \<in> set ms \<and> t \<in># m)"
    using schedule_def msch ms_le_ts
     by (metis (no_types, hide_lams) Un_iff in_Union_mset_iff set_append set_mset_mset ts_def)
  then obtain m where t_in_m: "t \<in> set qs \<longrightarrow> (m \<in> set ms \<and> t \<in># m)" by auto
  obtain u where u_in_m: "m \<in> set ms \<longrightarrow> u \<in> set rs \<and> u \<in># m" using opt_greedy by auto
  have "t \<in> set qs \<and> m \<in> set ms \<longrightarrow> t + u \<le> sum_mset m"
  proof (cases "t \<noteq> u")
    case True
    hence "t \<in> set qs \<and> m \<in> set ms \<longrightarrow> mset [t, u] \<subseteq># m" by (meson pair_in_mset t_in_m u_in_m)
    thus ?thesis using sum_mset_subset_eq by fastforce
  next
    case False
    have "t \<in> set qs \<and> m \<in> set ms \<longrightarrow> count m t \<ge> 2" sorry
    thus ?thesis using False sum_mset_replicate
      by (metis count_le_replicate_mset_subset_eq mult_2)
  qed
  moreover have "t \<in> set qs \<and> m \<in> set ms \<longrightarrow> t \<le> u"
    using ts_def ts_sorted ms_le_ts sorted_append u_in_m by blast
  moreover have "m \<in> set ms \<longrightarrow> makespan ms \<ge> sum_mset m" using makespan_def by simp
  ultimately show ?thesis using ms_le_ts t_in_m u_in_m by auto
qed

text \<open>As before, we avoid reasoning about array indices by defining the structure of 'ts'.
      In addition to 'j' (the index of the last job contributing to the makespan),
      the textbook proof of the stronger Theorem 11.5 also uses the index 'm',
      which is equal to the number of machines available. We encode it by defining 'vs'
      as a concatenation of lists 'qs' (jobs m+1..j) and 'rs' (jobs 1..m).

      This means that 'j' is implicitly assumed to be greater than 'm'.
      This assumption is present in the second paragraph of textbook proof.\<close>

theorem sorted_balance_optimal: (* Theorem 11.5 in KT *)
  assumes
    mpos:    "m > 0" and
    mrep:    "ms = replicate m {#}" and
    ts_def:  "ts = us@vs \<and> length vs > 0 \<and> (\<forall> t. t \<in> set ts \<longrightarrow> t > 0)" and
    mos_def:  "schedule ts mos \<and> length mos = m" and
    topt:    "Topt = makespan mos" and
    T_def:   "T = makespan (balance ts ms)" and
    j_def:   "T = hd vs + premakespan (balance (tl vs) ms)" and
    (* Additional assumptions allow us to prove a tighter upper bound: *)
    ms_le_ts: "vs = qs@rs \<and> length qs > 0 \<and> length rs = m" and
    ts_sorted: "sorted ts" and
    opt_greedy: "\<forall>m. m \<in> set mos \<longrightarrow> (\<exists>u. u \<in> set rs \<and> u \<in># m)"
  shows "2 * T \<le> 3 * Topt"
proof -
  have "hd vs \<in> set qs" using ms_le_ts by simp
  moreover have "2 * T - 2 * hd vs \<le> 2 * Topt" using balance_optimal_common assms
    by (metis nat_mult_le_cancel_disj right_diff_distrib')
  ultimately have "2 * T - 2 * hd vs + 2 * hd vs \<le> 3 * Topt" using makespan_ge_2t assms
    by (metis add.commute add_mono mult_Suc numeral_2_eq_2 numeral_3_eq_3)
  thus ?thesis using add_increasing2 by linarith
qed


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Enumerations of Well-Ordered Sets in Increasing Order *}

theory Least_Enum
imports Main
begin

locale infinitely_many1 =
  fixes P :: "'a :: wellorder \<Rightarrow> bool"
  assumes infm: "\<forall>i. \<exists>j>i. P j"
begin

text {*
  Enumerate the elements of a well-ordered infinite set in increasing order.
*}
fun enum :: "nat \<Rightarrow> 'a" where
  "enum 0 = (LEAST n. P n)" |
  "enum (Suc i) = (LEAST n. n > enum i \<and> P n)"

lemma enum_mono:
  shows "enum i < enum (Suc i)"
  using infm by (cases i, auto) (metis (lifting) LeastI)+

lemma enum_less:
  "i < j \<Longrightarrow> enum i < enum j"
  using enum_mono by (metis lift_Suc_mono_less)

lemma enum_P:
  shows "P (enum i)"
  using infm by (cases i, auto) (metis (lifting) LeastI)+

end

locale infinitely_many2 =
  fixes P :: "'a :: wellorder \<Rightarrow> 'a \<Rightarrow> bool"
    and N :: "'a"
  assumes infm: "\<forall>i\<ge>N. \<exists>j>i. P i j"
begin

text {*
  Enumerate the elements of a well-ordered infinite set that form a chain w.r.t.\ a given predicate
  @{term P} starting from a given index @{term N} in increasing order.
*}
fun enumchain :: "nat \<Rightarrow> 'a" where
  "enumchain 0 = N" |
  "enumchain (Suc n) = (LEAST m. m > enumchain n \<and> P (enumchain n) m)"

lemma enumchain_mono:
  shows "N \<le> enumchain i \<and> enumchain i < enumchain (Suc i)"
proof (induct i)
  case 0
  have "enumchain 0 \<ge> N" by simp
  moreover then have "\<exists>m>enumchain 0. P (enumchain 0) m" using infm by blast
  ultimately show ?case by auto (metis (lifting) LeastI)
next
  case (Suc i)
  then have "N \<le> enumchain (Suc i)" by auto
  moreover then have "\<exists>m>enumchain (Suc i). P (enumchain (Suc i)) m" using infm by blast
  ultimately show ?case by (auto) (metis (lifting) LeastI)
qed

lemma enumchain_chain:
  shows "P (enumchain i) (enumchain (Suc i))"
proof (cases i)
  case 0
  moreover have "\<exists>m>enumchain 0. P (enumchain 0) m" using infm by auto
  ultimately show ?thesis by auto (metis (lifting) LeastI)
next
  case (Suc i)
  moreover have "enumchain (Suc i) > N" using enumchain_mono by (metis le_less_trans)
  moreover then have "\<exists>m>enumchain (Suc i). P (enumchain (Suc i)) m" using infm by auto
  ultimately show ?thesis by (auto) (metis (lifting) LeastI)
qed

end

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Veblen Hierarchies\<close>

theory OrdinalVeblen
imports OrdinalOmega
begin

subsection \<open>Closed, unbounded sets\<close>

locale normal_set =
fixes A :: "ordinal set"
assumes closed:    "\<And>g. \<forall>n. g n \<in> A \<Longrightarrow> oLimit g \<in> A"
    and unbounded: "\<And>x. \<exists>y\<in>A. x < y"

lemma (in normal_set) less_next: "x < (LEAST z. z \<in> A \<and> x < z)"
 apply (rule LeastI2_ex)
 apply (fold Bex_def, rule unbounded)
 apply (erule conjunct2)
done

lemma (in normal_set) mem_next: "(LEAST z. z \<in> A \<and> x < z) \<in> A"
 apply (rule LeastI2_ex)
 apply (fold Bex_def, rule unbounded)
 apply (erule conjunct1)
done

lemma (in normal) normal_set_range: "normal_set (range F)"
 apply (rule normal_set.intro)
  apply (simp add: image_def)
  apply (rule_tac x="oLimit (\<lambda>n. LEAST x. g n = F x)" in exI)
  apply (simp only: oLimit)
  apply (rule_tac f=oLimit in arg_cong)
  apply (rule ext)
  apply (rule LeastI_ex)
  apply (erule spec)
 apply (rule_tac x="F (oSuc x)" in bexI)
  apply (rule order_le_less_trans [OF increasing])
  apply (simp add: cancel_less)
 apply (rule rangeI)
done

lemma oLimit_mem_INTER:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n;
  \<forall>n. f n \<in> A n; mono f\<rbrakk>
  \<Longrightarrow> oLimit f \<in> (\<Inter>n. A n)"
 apply (clarsimp, rename_tac k)
 apply (subgoal_tac "oLimit (\<lambda>n. f (n + k)) \<in> A k")
  apply (simp add: oLimit_shift_mono)
 apply (rule normal_set.closed [rule_format], erule spec)
 apply (rule_tac A="A (n + k)" in subsetD)
  apply (induct_tac n, simp, rename_tac m)
  apply (rule_tac B="A (m + k)" in subset_trans, simp, simp)
 apply (erule spec)
done

lemma normal_set_INTER:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n\<rbrakk> \<Longrightarrow> normal_set (\<Inter>n. A n)"
 apply (rule normal_set.intro)
  apply (clarsimp simp add: normal_set.closed)
 apply (rule_tac x="oLimit (\<lambda>n. LEAST y. y \<in> A n \<and> x < y)" in bexI)
  apply (rule_tac y="LEAST y. y \<in> A n \<and> x < y" in order_less_le_trans)
   apply (simp only: normal_set.less_next)
  apply (rule le_oLimit)
 apply (rule oLimit_mem_INTER, assumption+)
  apply (simp add: normal_set.mem_next)
 apply (rule mono_natI)
 apply (rule Least_le)
 apply (rule conjI)
  apply (rule subsetD, erule spec)
  apply (simp only: normal_set.mem_next)
 apply (simp only: normal_set.less_next)
done

subsection \<open>Ordering functions\<close>

text "There is a one-to-one correspondence between closed,
unbounded sets of ordinals and normal functions on ordinals."

definition
  ordering  :: "(ordinal set) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" where
  "ordering A = ordinal_rec (LEAST z. z \<in> A) (\<lambda>p x. LEAST z. z \<in> A \<and> x < z)"

lemma ordering_0:
"ordering A 0 = (LEAST z. z \<in> A)"
by (simp add: ordering_def)

lemma ordering_oSuc:
"ordering A (oSuc x) = (LEAST z. z \<in> A \<and> ordering A x < z)"
by (simp add: ordering_def)

lemma (in normal_set) normal_ordering: "normal (ordering A)"
 apply (unfold ordering_def)
 apply (rule normal_ordinal_rec [rule_format])
 apply (rule less_next)
done

lemma (in normal_set) ordering_oLimit:
"ordering A (oLimit f) = oLimit (\<lambda>n. ordering A (f n))"
 apply (rule normal.oLimit)
 apply (rule normal_ordering)
done

lemma (in normal) ordering_range: "ordering (range F) = F"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: ordering_0)
   apply (rule Least_equality)
    apply (rule rangeI)
   apply (clarsimp simp add: cancel_le)
  apply (simp add: ordering_oSuc)
  apply (rule Least_equality)
   apply (simp add: cancel_less)
  apply (clarsimp simp add: cancel_le cancel_less oSuc_leI)
 apply (subst normal_set.ordering_oLimit)
  apply (rule normal_set_range)
 apply (simp add: oLimit)
done

lemma (in normal_set) ordering_mem: "ordering A x \<in> A"
 apply (rule_tac a=x in oLimit_induct)
   apply (subst ordering_0)
   apply (rule LeastI_ex)
   apply (cut_tac unbounded, force)
  apply (subst ordering_oSuc)
  apply (rule mem_next)
 apply (subst ordering_oLimit)
 apply (erule closed)
done

lemma (in normal_set) range_ordering_lemma:
"\<forall>y. y \<in> A \<longrightarrow> y < ordering A x \<longrightarrow> y \<in> range (ordering A)"
 apply (simp add: image_def)
 apply (rule_tac a=x in oLimit_induct, safe)
   apply (simp add: ordering_0)
   apply (drule not_less_Least, simp)
  apply (simp add: ordering_oSuc)
  apply (drule not_less_Least, simp)
  apply (force simp add: linorder_not_less order_le_less)
 apply (simp add: ordering_oLimit)
 apply (drule less_oLimitD, clarsimp)
done

lemma (in normal_set) range_ordering: "range (ordering A) = A"
 apply (safe intro!: ordering_mem)
 apply (erule_tac x="oSuc x" in range_ordering_lemma[rule_format])
 apply (rule order_less_le_trans[OF less_oSuc])
 apply (rule normal.increasing[OF normal_ordering])
done

lemma ordering_INTER_0:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n\<rbrakk>
 \<Longrightarrow> ordering (\<Inter>n. A n) 0 = oLimit (\<lambda>n. ordering (A n) 0)"
 apply (subst ordering_0)
 apply (rule Least_equality)
  apply (rule oLimit_mem_INTER, assumption+)
   apply (simp add: normal_set.ordering_mem)
  apply (rule mono_natI)
  apply (simp add: ordering_0)
  apply (rule Least_le)
  apply (rule subsetD, erule spec)
  apply (drule_tac x="Suc n" in spec)
  apply (drule normal_set.unbounded, clarify)
  apply (erule LeastI)
 apply (rule oLimit_leI[rule_format])
 apply (simp add: ordering_0)
 apply (rule Least_le)
 apply (erule spec)
done

subsection \<open>Critical ordinals\<close>

definition
  critical_set :: "ordinal set \<Rightarrow> ordinal \<Rightarrow> ordinal set" where
  "critical_set A =
     ordinal_rec0 A (\<lambda>p x. x \<inter> range (oDeriv (ordering x))) (\<lambda>f. \<Inter>n. f n)"

lemma critical_set_0:
"critical_set A 0 = A"
by (unfold critical_set_def, rule ordinal_rec0_0)

lemma critical_set_oSuc_lemma:
"critical_set A (oSuc n) =
  critical_set A n \<inter> range (oDeriv (ordering (critical_set A n)))"
by (unfold critical_set_def, rule ordinal_rec0_oSuc)

lemma omega_complete_INTER:
"omega_complete (\<lambda>x y. y \<subseteq> x) (\<lambda>f. \<Inter> (range f))"
 apply (rule omega_complete.intro)
  apply (rule porder.flip)
  apply (rule porder_order)
 apply (rule omega_complete_axioms.intro)
  apply fast
 apply fast
done

lemma critical_set_oLimit:
"critical_set A (oLimit f) = (\<Inter>n. critical_set A (f n))"
 apply (unfold critical_set_def)
 apply (rule omega_complete.ordinal_rec0_oLimit)
  apply (rule omega_complete_INTER)
 apply fast
done

lemma critical_set_mono:
"x \<le> y \<Longrightarrow> critical_set A y \<subseteq> critical_set A x"
 apply (unfold critical_set_def)
 apply (rule omega_complete.ordinal_rec0_mono
          [OF omega_complete_INTER])
  apply fast
 apply assumption
done

lemma (in normal_set) range_oDeriv_subset:
"range (oDeriv (ordering A)) \<subseteq> A"
 apply (clarsimp, rename_tac x)
 apply (cut_tac n=x in oDeriv_fixed[OF normal_ordering])
 apply (erule subst)
 apply (rule ordering_mem)
done

lemma normal_set_critical_set:
"normal_set A \<Longrightarrow> normal_set (critical_set A x)"
 apply (rule_tac a=x in oLimit_induct)
   apply (simp only: critical_set_0)
  apply (simp only: critical_set_oSuc_lemma)
  apply (subst Int_absorb1)
   apply (erule normal_set.range_oDeriv_subset)
  apply (rule normal.normal_set_range)
  apply (rule normal_oDeriv)
 apply (simp only: critical_set_oLimit)
 apply (erule normal_set_INTER)
 apply (rule allI, rule critical_set_mono)
 apply (simp add: strict_mono_monoD)
done

lemma critical_set_oSuc:
"normal_set A
 \<Longrightarrow> critical_set A (oSuc x) = range (oDeriv (ordering (critical_set A x)))"
 apply (simp only: critical_set_oSuc_lemma)
 apply (rule Int_absorb1)
 apply (rule normal_set.range_oDeriv_subset)
 apply (erule normal_set_critical_set)
done

subsection \<open>Veblen hierarchy over a normal function\<close>

definition
  oVeblen :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oVeblen F = (\<lambda>x. ordering (critical_set (range F) x))"

lemma (in normal) oVeblen_0: "oVeblen F 0 = F"
 apply (unfold oVeblen_def)
 apply (subst critical_set_0)
 apply (rule ordering_range)
done

lemma (in normal) oVeblen_oSuc:
"oVeblen F (oSuc x) = oDeriv (oVeblen F x)"
 apply (unfold oVeblen_def)
 apply (subst critical_set_oSuc)
  apply (rule normal_set_range)
 apply (rule normal.ordering_range)
 apply (rule normal_oDeriv)
done

lemma (in normal) oVeblen_oLimit:
"oVeblen F (oLimit f) = ordering (\<Inter>n. range (oVeblen F (f n)))"
 apply (unfold oVeblen_def)
 apply (subst critical_set_oLimit)
 apply (cut_tac normal_set_range)
 apply (simp add: normal_set.range_ordering[OF normal_set_critical_set])
done

lemma (in normal) normal_oVeblen:
"normal (oVeblen F x)"
 apply (unfold oVeblen_def)
 apply (rule normal_set.normal_ordering)
 apply (rule normal_set_critical_set)
 apply (rule normal_set_range)
done

lemma (in normal) continuous_oVeblen_0:
"continuous (\<lambda>x. oVeblen F x 0)"
 apply (rule continuousI)
  apply (simp add: oVeblen_def critical_set_oLimit)
  apply (rule ordering_INTER_0[rule_format])
   apply (rule normal_set_critical_set)
   apply (rule normal_set_range)
  apply (rule critical_set_mono)
  apply (simp add: strict_mono_monoD)
 apply (simp only: oVeblen_oSuc)
 apply (rule oDeriv_increasing)
 apply (rule normal.continuous)
 apply (rule normal_oVeblen)
done

lemma (in normal) oVeblen_oLimit_0:
"oVeblen F (oLimit f) 0 = oLimit (\<lambda>n. oVeblen F (f n) 0)"
by (rule continuousD[OF continuous_oVeblen_0])

lemma (in normal) normal_oVeblen_0:
"0 < F 0 \<Longrightarrow> normal (\<lambda>x. oVeblen F x 0)"
 apply (rule normalI)
  apply (rule oVeblen_oLimit_0)
 apply (simp only: oVeblen_oSuc)
 apply (subst oDeriv_fixed[OF normal_oVeblen, symmetric])
 apply (rule normal.strict_monoD[OF normal_oVeblen])
 apply (simp add: zero_less_oFix_eq)
 apply (erule order_less_le_trans)
 apply (subgoal_tac "oVeblen F 0 0 \<le> oVeblen F x 0")
  apply (simp add: oVeblen_0)
 apply (rule continuous.monoD[OF _ ordinal_0_le])
 apply (rule continuous_oVeblen_0)
done

lemma (in normal) range_oVeblen:
"range (oVeblen F x) = critical_set (range F) x"
 apply (unfold oVeblen_def)
 apply (rule normal_set.range_ordering)
 apply (rule normal_set_critical_set)
 apply (rule normal_set_range)
done

lemma (in normal) range_oVeblen_subset:
"x \<le> y \<Longrightarrow> range (oVeblen F y) \<subseteq> range (oVeblen F x)"
 apply (simp only: range_oVeblen)
 apply (erule critical_set_mono)
done

lemma (in normal) oVeblen_fixed:
"\<forall>x<y. \<forall>a. oVeblen F x (oVeblen F y a) = oVeblen F y a"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp simp only: oVeblen_oSuc)
  apply (erule less_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (drule_tac x="oDeriv (oVeblen F x) a" in spec)
   apply (simp add: oDeriv_fixed normal_oVeblen)
  apply simp
  apply (rule oDeriv_fixed)
  apply (rule normal_oVeblen)
 apply clarsimp
 apply (erule less_oLimitE)
 apply (drule spec, drule spec, drule mp, assumption)
 apply (subgoal_tac "oVeblen F (oLimit f) a \<in> range (oVeblen F (f n))")
  apply clarsimp
 apply (rule_tac A="range (oVeblen F (oLimit f))" in subsetD)
  apply (rule range_oVeblen_subset)
  apply (rule le_oLimit)
 apply (rule rangeI)
done

lemma (in normal) critical_set_fixed:
"0 < z \<Longrightarrow> range (oVeblen F z) = {x. \<forall>y<z. oVeblen F y x = x}"
 apply (rule equalityI)
  apply (clarsimp simp add: oVeblen_fixed)
 apply (erule rev_mp)
 apply (rule_tac a=z in oLimit_induct)
   apply simp
  apply clarsimp
  apply (simp add: oVeblen_oSuc range_oDeriv normal_oVeblen)
 apply clarsimp
 apply (simp add: range_oVeblen)
 apply (clarsimp simp add: critical_set_oLimit)
 apply (rule_tac A="critical_set (range F) (f (Suc xa))" in subsetD)
  apply (rule critical_set_mono)
  apply (simp add: strict_mono_monoD)
 apply (drule_tac x="Suc xa" in spec, drule mp)
  apply (rule_tac y="f xa" in order_le_less_trans, simp)
  apply (erule OrdinalInduct.strict_monoD, simp)
 apply (erule subsetD, clarsimp)
 apply (drule spec, erule mp)
 apply (erule order_less_le_trans)
 apply (rule le_oLimit)
done

subsection \<open>Veblen hierarchy over $\lambda x.\ 1 + x$\<close>

lemma oDeriv_id: "oDeriv id = id"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: oFix_eq_self)
  apply (simp add: oFix_eq_self)
 apply simp
done

lemma oFix_plus: "oFix (\<lambda>x. a + x) 0 = a * \<omega>"
 apply (simp add: oFix_def omega_def)
 apply (rule_tac f=oLimit in arg_cong)
 apply (rule ext, induct_tac n, simp)
 apply (simp, rename_tac n)
 apply (induct_tac n, simp)
 apply (simp add: ordinal_plus_assoc[symmetric])
done

lemma oDeriv_plus: "oDeriv ((+) a) = ((+) (a * \<omega>))"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: oFix_plus)
  apply (simp add: oFix_eq_self
                   ordinal_plus_assoc[symmetric]
                   ordinal_plus_times_omega)
 apply simp
done

lemma oVeblen_1_plus: "oVeblen ((+) 1) x = ((+) (\<omega> ** x))"
 apply (rule_tac a=x in wf_induct[OF wf], simp)
 apply (rule_tac a=x in ordinal_cases)
   apply (simp add: normal.oVeblen_0[OF normal_plus])
  apply (simp add: normal.oVeblen_oSuc[OF normal_plus])
  apply (simp add: oDeriv_plus)
 apply clarsimp
 apply (rule normal_range_eq)
   apply (rule normal.normal_oVeblen[OF normal_plus])
  apply (rule normal_plus)
 apply (subst normal.critical_set_fixed[OF normal_plus])
  apply (rule_tac y="f 0" in order_le_less_trans, simp)
  apply (simp add: strict_mono_less_oLimit)
 apply safe
  apply (simp add: image_def)
  apply (rule exI, rule ordinal_plus_minus2[symmetric])
  apply (rule oLimit_leI[rule_format])
  apply (subgoal_tac "\<omega> ** f n + x = x", erule subst, simp)
  apply (drule_tac x="f n" in spec)
  apply (simp add: strict_mono_less_oLimit)
 apply simp
 apply (simp only: ordinal_exp_oLimit[symmetric] zero_less_omega)
 apply (simp only: ordinal_plus_assoc[symmetric])
 apply (simp only: absorb_omega_exp2)
done

end