section \<open>Exponentiation of ordinals\<close>

theory Ordinal_Exp
  imports Kirby

begin

text \<open>Source: Schlöder, Julian.  Ordinal Arithmetic; available online at
    \url{http://www.math.uni-bonn.de/ag/logik/teaching/2012WS/Set%20theory/oa.pdf}\<close>

definition oexp :: "[V,V] \<Rightarrow> V" (infixr "\<up>" 80)
  where "oexp a b \<equiv> transrec (\<lambda>f x. if x=0 then 1
                                    else if Limit x then if a=0 then 0 else \<Squnion>\<xi> \<in> elts x. f \<xi>
                                    else f (\<Squnion>(elts x)) * a)  b"

text \<open>@{term "0\<up>\<omega> = 1"} if we don't make a special case for Limit ordinals and zero\<close>

lemma oexp_0_right [simp]: "\<alpha>\<up>0 = 1"
  by (simp add: def_transrec [OF oexp_def])

lemma oexp_succ [simp]: "Ord \<beta> \<Longrightarrow> \<alpha>\<up>(succ \<beta>) = \<alpha>\<up>\<beta> * \<alpha>"
  by (simp add: def_transrec [OF oexp_def])

lemma oexp_Limit: "Limit \<beta> \<Longrightarrow> \<alpha>\<up>\<beta> = (if \<alpha>=0 then 0 else \<Squnion>\<xi> \<in> elts \<beta>. \<alpha>\<up>\<xi>)"
  by (auto simp: def_transrec [OF oexp_def, of _ \<beta>])

lemma oexp_1_right [simp]: "\<alpha>\<up>1 = \<alpha>"
  using one_V_def oexp_succ by fastforce

lemma oexp_1 [simp]: "Ord \<alpha> \<Longrightarrow> 1\<up>\<alpha> = 1"
  by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)

lemma oexp_0 [simp]: "Ord \<alpha> \<Longrightarrow> 0\<up>\<alpha> = (if \<alpha> = 0 then 1 else 0)"
  by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)

lemma oexp_eq_0_iff [simp]:
  assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> = 0 \<longleftrightarrow> \<alpha>=0 \<and> \<beta>\<noteq>0"
  using \<open>Ord \<beta>\<close>
proof (induction rule: Ord_induct3)
  case (Limit \<mu>)
  then show ?case
    using Limit_def oexp_Limit by auto
qed auto

lemma oexp_gt_0_iff [simp]:
  assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> > 0 \<longleftrightarrow> \<alpha>>0 \<or> \<beta>=0"
  by (simp add: assms less_V_def)

lemma ord_of_nat_oexp: "ord_of_nat (m^n) = ord_of_nat m\<up>ord_of_nat n"
proof (induction n)
  case (Suc n)
  then show ?case
    by (simp add: mult.commute [of m]) (simp add: ord_of_nat_mult)
qed auto

lemma omega_closed_oexp [intro]:
  assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>\<up>\<beta> \<in> elts \<omega>"
proof -
  obtain m n where "\<alpha> = ord_of_nat m" "\<beta> = ord_of_nat n"
    using assms elts_\<omega> by auto
  then have "\<alpha>\<up>\<beta> = ord_of_nat (m^n)"
    by (simp add: ord_of_nat_oexp)
  then show ?thesis
    by (simp add: \<omega>_def)
qed

lemma Ord_oexp [simp]:
  assumes "Ord \<alpha>" "Ord \<beta>" shows "Ord (\<alpha>\<up>\<beta>)"
  using \<open>Ord \<beta>\<close>
proof (induction rule: Ord_induct3)
  case (Limit \<alpha>)
  then show ?case
    by (auto simp: oexp_Limit image_iff intro: Ord_Sup)
qed (auto intro: Ord_mult assms)

text \<open>Lemma 3.19\<close>
lemma le_oexp:
  assumes "Ord \<alpha>" "Ord \<beta>" "\<beta> \<noteq> 0" shows "\<alpha> \<le> \<alpha>\<up>\<beta>"
  using \<open>Ord \<beta>\<close> \<open>\<beta> \<noteq> 0\<close>
proof (induction rule: Ord_induct3)
  case (succ \<beta>)
  then show ?case
    by simp (metis \<open>Ord \<alpha>\<close> le_0 le_mult mult.left_neutral oexp_0_right order_refl order_trans)
next
  case (Limit \<mu>)
  then show ?case
    by (metis Limit_def Limit_eq_Sup_self ZFC_in_HOL.Sup_upper eq_iff image_eqI image_ident oexp_1_right oexp_Limit replacement small_elts one_V_def)
qed auto

text \<open>Lemma 3.20\<close>
lemma le_oexp':
  assumes "Ord \<alpha>" "1 < \<alpha>" "Ord \<beta>" shows "\<beta> \<le> \<alpha>\<up>\<beta>"
proof (cases "\<beta> = 0")
  case True
  then show ?thesis
    by auto
next
  case False
  show ?thesis
    using \<open>Ord \<beta>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<gamma>)
    then have "\<alpha>\<up>\<gamma> * 1 < \<alpha>\<up>\<gamma> * \<alpha>"
      using \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close>
      by (metis le_mult less_V_def mult.right_neutral mult_cancellation not_less_0 oexp_eq_0_iff succ.hyps)
    then have " \<gamma> < \<alpha>\<up>succ \<gamma>"
      using succ.IH succ.hyps by auto
    then show ?case
      using False \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close> succ
      by (metis Ord_mem_iff_lt Ord_oexp Ord_succ elts_succ insert_subset less_eq_V_def less_imp_le)
  next
    case (Limit \<mu>)
    with False \<open>1 < \<alpha>\<close> show ?case
      by (force simp: Limit_def oexp_Limit intro: elts_succ)
  qed
qed

lemma oexp_Limit_le:
  assumes "\<beta> < \<gamma>" "Limit \<gamma>" "Ord \<beta>" "\<alpha> > 0" shows "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
proof -
  have "Ord \<gamma>"
    using Limit_def assms(2) by blast
  with assms show ?thesis
    using Ord_mem_iff_lt ZFC_in_HOL.Sup_upper oexp_Limit by auto
qed

proposition oexp_less:
  assumes \<beta>: "\<beta> \<in> elts \<gamma>" and "Ord \<gamma>" and \<alpha>: "\<alpha> > 1" "Ord \<alpha>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
proof -
  obtain "\<beta> < \<gamma>" "Ord \<beta>"
    using Ord_in_Ord OrdmemD assms by auto
  have gt0: "\<alpha>\<up>\<beta> > 0"
    using \<open>Ord \<beta>\<close> \<alpha> dual_order.order_iff_strict by auto
  show ?thesis
    using \<open>Ord \<gamma>\<close> \<beta>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<delta>)
    then consider "\<beta> = \<delta>" | "\<beta> < \<delta>"
      using OrdmemD elts_succ by blast
    then show ?case
    proof cases
      case 1
      then have "(\<alpha>\<up>\<beta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
        using Ord_1 Ord_oexp \<alpha> gt0 mult_cancel_less_iff succ.hyps by metis
      then show ?thesis
        by (simp add: succ.hyps)
    next
      case 2
      then have "(\<alpha>\<up>\<delta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
        by (meson Ord_1 Ord_mem_iff_lt Ord_oexp \<open>Ord \<beta>\<close> \<alpha> gt0 less_trans mult_cancel_less_iff succ)
      with 2 show ?thesis
        using Ord_mem_iff_lt \<open>Ord \<beta>\<close> succ by auto
    qed
  next
    case (Limit \<gamma>)
    then obtain "Ord \<gamma>" "succ \<beta> < \<gamma>"
      using Limit_def Ord_in_Ord OrdmemD assms by auto
    have "\<alpha>\<up>\<beta> = (\<alpha>\<up>\<beta>) * 1"
      by simp
    also have "\<dots> < (\<alpha>\<up>\<beta>) * \<alpha>"
      using Ord_oexp \<open>Ord \<beta>\<close> assms gt0 mult_cancel_less_iff by blast
    also have "\<dots> = \<alpha>\<up>succ \<beta>"
      by (simp add: \<open>Ord \<beta>\<close>)
    also have "\<dots> \<le> (\<Squnion>\<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)"
    proof -
      have "succ \<beta> \<in> elts \<gamma>"
        using Limit.hyps Limit.prems Limit_def by auto
      then show ?thesis
        by (simp add: ZFC_in_HOL.Sup_upper)
    qed
    finally
    have "\<alpha>\<up>\<beta> < (\<Squnion>\<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)" .
    then show ?case
      using Limit.hyps oexp_Limit \<open>\<alpha> > 1\<close> by auto
  qed
qed

corollary oexp_less_iff:
  assumes "\<alpha> > 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma> \<longleftrightarrow> \<beta> \<in> elts \<gamma> \<and> \<alpha> > 1"
proof safe
  show "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
    if "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
  proof -
    show "\<alpha> > 1"
    proof (rule ccontr)
      assume "\<not> \<alpha> > 1"
      then consider "\<alpha>=0" | "\<alpha>=1"
        using \<open>Ord \<alpha>\<close> less_V_def mem_0_Ord by fastforce
      then show False
        by cases (use that \<open>\<alpha> > 0\<close> \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> in \<open>auto split: if_split_asm\<close>)
    qed
    show \<beta>: "\<beta> \<in> elts \<gamma>"
    proof (rule ccontr)
      assume "\<beta> \<notin> elts \<gamma>"
      then have "\<gamma> \<le> \<beta>"
        by (meson Ord_linear_le Ord_mem_iff_lt assms less_le_not_le)
      then consider "\<gamma> = \<beta>" | "\<gamma> < \<beta>"
        using less_V_def by blast
      then show False
      proof cases
        case 1
        then show ?thesis
          using that by blast
      next
        case 2
        with \<open>\<alpha> > 1\<close> have "\<alpha>\<up>\<gamma> < \<alpha>\<up>\<beta>"
          by (simp add: Ord_mem_iff_lt assms oexp_less)
        with that show ?thesis
          by auto
      qed
    qed
  qed
  show "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>" if "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
    using that by (simp add: assms oexp_less)
qed

lemma \<omega>_oexp_iff [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> \<omega>\<up>\<alpha> = \<omega>\<up>\<beta> \<longleftrightarrow> \<alpha>=\<beta>"
  by (metis Ord_\<omega> Ord_linear \<omega>_gt1 less_irrefl oexp_less)

lemma Limit_oexp:
  assumes "Limit \<gamma>" "Ord \<alpha>" "\<alpha> > 1" shows "Limit (\<alpha>\<up>\<gamma>)"
  unfolding Limit_def
proof safe
  show O\<alpha>\<gamma>: "Ord (\<alpha>\<up>\<gamma>)"
    using Limit_def Ord_oexp \<open>Limit \<gamma>\<close> assms(2) by blast
  show 0: "0 \<in> elts (\<alpha>\<up>\<gamma>)"
    using Limit_def oexp_Limit \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close> by fastforce
  have "Ord \<gamma>"
    using Limit_def \<open>Limit \<gamma>\<close> by blast
  fix x
  assume x: "x \<in> elts (\<alpha>\<up>\<gamma>)"
  with \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close>
  obtain \<beta> where "\<beta> < \<gamma>" "Ord \<beta>" "Ord x" and x\<beta>: "x \<in> elts (\<alpha>\<up>\<beta>)"
    apply (simp add: oexp_Limit split: if_split_asm)
    using Ord_in_Ord OrdmemD \<open>Ord \<gamma>\<close> O\<alpha>\<gamma> x by blast
  then have O\<alpha>\<beta>: "Ord (\<alpha>\<up>\<beta>)"
    using Ord_oexp assms(2) by blast
  have "\<beta> \<in> elts \<gamma>"
    by (simp add: Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> \<open>\<beta> < \<gamma>\<close>)
  moreover have "\<alpha> \<noteq> 0"
    using \<open>\<alpha> > 1\<close> by blast
  ultimately have \<alpha>\<beta>\<gamma>: "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
    by (simp add: Sup_upper oexp_Limit \<open>Limit \<gamma>\<close>)
  have "succ x \<le> \<alpha>\<up>\<beta>"
    by (simp add: OrdmemD O\<alpha>\<beta> \<open>Ord x\<close> succ_le_iff x\<beta>)
  then consider "succ x < \<alpha>\<up>\<beta>" | "succ x = \<alpha>\<up>\<beta>"
    using le_neq_trans by blast
  then show "succ x \<in> elts (\<alpha>\<up>\<gamma>)"
  proof cases
    case 1
    with \<alpha>\<beta>\<gamma> show ?thesis
      using O\<alpha>\<beta> Ord_mem_iff_lt \<open>Ord x\<close> by blast
  next
    case 2
    then have "succ \<beta> < \<gamma>"
      using Limit_def OrdmemD \<open>\<beta> \<in> elts \<gamma>\<close> assms(1) by auto
    have ge1: "1 \<le> \<alpha>\<up>\<beta>"
      by (metis "2" Ord_0 \<open>Ord x\<close> le_0 le_succ_iff one_V_def)
    have "succ x < succ (\<alpha>\<up>\<beta>)"
      using "2" O\<alpha>\<beta> succ_le_iff by auto
    also have "\<dots> \<le> (\<alpha>\<up>\<beta>) + (\<alpha>\<up>\<beta>)"
      using ge1 by (simp add: succ_eq_add1)
    also have "\<dots> = (\<alpha>\<up>\<beta>) * succ (succ 0)"
      by (simp add: mult_succ)
    also have "\<dots> \<le> (\<alpha>\<up>\<beta>) * \<alpha>"
      using O\<alpha>\<beta> Ord_succ assms(2) assms(3) one_V_def succ_le_iff by auto
    also have "\<dots> = \<alpha>\<up>succ \<beta>"
      by (simp add: \<open>Ord \<beta>\<close>)
    also have "\<dots> \<le> \<alpha>\<up>\<gamma>"
      by (meson Limit_def \<open>\<beta> \<in> elts \<gamma>\<close> assms dual_order.order_iff_strict oexp_less)
  finally show ?thesis
    by (simp add: "2" O\<alpha>\<beta> O\<alpha>\<gamma> Ord_mem_iff_lt)
  qed
qed

lemma oexp_mono:
  assumes \<alpha>: "Ord \<alpha>" "\<alpha> \<noteq> 0" and \<beta>: "Ord \<beta>" "\<gamma> \<sqsubseteq> \<beta>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
  using \<beta>
proof (induction rule: Ord_induct3)
  case 0
  then show ?case
    by simp
next
  case (succ \<beta>)
  with \<alpha> le_mult show ?case
    by (auto simp: le_TC_succ)
next
  case (Limit \<mu>)
  then have "\<alpha>\<up>\<gamma> \<le> \<Squnion> ((\<up>) \<alpha> ` elts \<mu>)"
    using Limit.hyps Ord_less_TC_mem \<open>\<alpha> \<noteq> 0\<close> le_TC_def by (auto simp: oexp_Limit Limit_def)
  then show ?case
    using \<alpha> by (simp add: oexp_Limit Limit.hyps)
qed

lemma oexp_mono_le:
  assumes "\<gamma> \<le> \<beta>" "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
  by (simp add: assms oexp_mono vle2 vle_iff_le_Ord)

lemma oexp_sup:
  assumes "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> \<squnion> \<gamma>) = \<alpha>\<up>\<beta> \<squnion> \<alpha>\<up>\<gamma>"
  by (metis Ord_linear_le assms oexp_mono_le sup.absorb2 sup.orderE)

lemma oexp_Sup:
  assumes \<alpha>: "\<alpha> \<noteq> 0" "Ord \<alpha>" and X: "X \<subseteq> ON" "small X" "X \<noteq> {}" shows "\<alpha>\<up>\<Squnion> X = \<Squnion> ((\<up>) \<alpha> ` X)"
proof (rule order_antisym)
  show "\<Squnion> ((\<up>) \<alpha> ` X) \<le> \<alpha>\<up>\<Squnion> X"
    by (metis ON_imp_Ord Ord_Sup ZFC_in_HOL.Sup_upper assms cSUP_least oexp_mono_le)
next
  have "Ord (Sup X)"
    using Ord_Sup X by auto
  then show "\<alpha>\<up>\<Squnion> X \<le> \<Squnion> ((\<up>) \<alpha> ` X)"
  proof (cases rule: Ord_cases)
    case 0
    then show ?thesis
      using X dual_order.antisym by fastforce
  next
    case (succ \<beta>)
    then show ?thesis
      using ZFC_in_HOL.Sup_upper X succ_in_Sup_Ord by auto
  next
    case limit
    show ?thesis
    proof (clarsimp simp: assms oexp_Limit limit)
      fix x y z
      assume x: "x \<in> elts (\<alpha> \<up> y)" and "z \<in> X" "y \<in> elts z"
      then have "\<alpha> \<up> y \<le> \<alpha> \<up> z"
        by (meson ON_imp_Ord Ord_in_Ord OrdmemD \<alpha> \<open>X \<subseteq> ON\<close> le_less oexp_mono_le)
      with x have "x \<in> elts (\<alpha> \<up> z)" by blast
      then show "\<exists>u\<in>X. x \<in> elts (\<alpha> \<up> u)"
        using \<open>z \<in> X\<close> by blast
    qed
  qed
qed

lemma omega_le_Limit:
  assumes "Limit \<mu>" shows "\<omega> \<le> \<mu>"
proof
  fix \<rho>
  assume "\<rho> \<in> elts \<omega>"
  then obtain n where "\<rho> = ord_of_nat n"
    using elts_\<omega> by auto
  have "ord_of_nat n \<in> elts \<mu>"
    by (induction n) (use Limit_def assms in auto)
  then show "\<rho> \<in> elts \<mu>"
    using \<open>\<rho> = ord_of_nat n\<close> by auto
qed

lemma finite_omega_power [simp]:
  assumes "1 < n" "n \<in> elts \<omega>" shows "n\<up>\<omega> = \<omega>"
proof (rule order_antisym)
  have "\<Squnion> ((\<up>) (ord_of_nat k) ` elts \<omega>) \<le> \<omega>" for k
  proof (induction k)
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    then show ?case
      by (metis Ord_\<omega> OrdmemD Sup_eq_0_iff ZFC_in_HOL.SUP_le_iff le_0 le_less omega_closed_oexp ord_of_nat_\<omega>)
  qed
  then show "n\<up>\<omega> \<le> \<omega>"
    using assms
    by (simp add: elts_\<omega> oexp_Limit) metis
  show "\<omega> \<le> n\<up>\<omega>"
    using Ord_in_Ord assms le_oexp' by blast
qed

proposition oexp_add:
  assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> + \<gamma>) = \<alpha>\<up>\<beta> * \<alpha>\<up>\<gamma>"
proof (cases \<open>\<alpha> = 0\<close>)
  case True
  then show ?thesis
    using assms by simp
next
  case False
  show ?thesis
    using \<open>Ord \<gamma>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<xi>)
    then show ?case
      using \<open>Ord \<beta>\<close> by (auto simp: plus_V_succ_right mult.assoc)
  next
    case (Limit \<mu>)
    have "\<alpha>\<up>(\<beta> + (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)) = (\<Squnion>\<xi>\<in>elts (\<beta> + \<mu>). \<alpha>\<up>\<xi>)"
      by (simp add: Limit.hyps oexp_Limit assms False)
    also have "\<dots> = (\<Squnion>\<xi> \<in> {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. \<alpha>\<up>(\<beta> + \<xi>))"
    proof (rule Sup_eq_Sup)
      show "(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>} \<subseteq> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
        using Limit.hyps Limit_def Ord_mem_iff_lt imageI by blast
      fix x
      assume "x \<in> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
      then obtain \<xi> where \<xi>: "\<xi> \<in> elts (\<beta> + \<mu>)" and x: "x = \<alpha>\<up>\<xi>"
        by auto
      have "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
      proof (rule mem_plus_V_E [OF \<xi>])
        assume "\<xi> \<in> elts \<beta>"
        then have "\<alpha>\<up>\<xi> \<le> \<alpha>\<up>\<beta>"
          by (meson arg_subset_TC assms False le_TC_def less_TC_def oexp_mono vsubsetD)
        with zero_less_Limit [OF \<open>Limit \<mu>\<close>]
        show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
          by force
      next
        fix \<delta>
        assume "\<delta> \<in> elts \<mu>" and "\<xi> = \<beta> + \<delta>"
        have "Ord \<delta>"
          using Limit.hyps Limit_def Ord_in_Ord \<open>\<delta> \<in> elts \<mu>\<close> by blast
        moreover have "\<delta> < \<mu>"
          using Limit.hyps Limit_def OrdmemD \<open>\<delta> \<in> elts \<mu>\<close> by auto
        ultimately show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
          using \<open>\<xi> = \<beta> + \<delta>\<close> by blast
      qed
      then show "\<exists>y\<in>(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. x \<le> y"
        using x by auto
    qed auto
    also have "\<dots> = (\<Squnion>\<xi>\<in>elts \<mu>. \<alpha>\<up>(\<beta> + \<xi>))"
      using \<open>Limit \<mu>\<close>
      by (simp add: Ord_Collect_lt Limit_def)
    also have "\<dots> = (\<Squnion>\<xi>\<in>elts \<mu>. \<alpha>\<up>\<beta> * \<alpha>\<up>\<xi>)"
      using Limit.IH by auto
    also have "\<dots> = \<alpha>\<up>\<beta> * \<alpha>\<up>(\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)"
      using \<open>\<alpha> \<noteq> 0\<close> Limit.hyps
      by (simp add: image_image oexp_Limit mult_Sup_distrib)
    finally show ?case .
  qed
qed

proposition oexp_mult:
  assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> * \<gamma>) = (\<alpha>\<up>\<beta>)\<up>\<gamma>"
proof (cases "\<alpha> = 0 \<or> \<beta> = 0")
  case True
  then show ?thesis
    by (auto simp: \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close>)
next
  case False
  show ?thesis
    using \<open>Ord \<gamma>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case succ
    then show ?case
      using assms by (auto simp: mult_succ oexp_add)
  next
    case (Limit \<mu>)
    have Lim: "Limit (\<Squnion> ((*) \<beta> ` elts \<mu>))"
      unfolding Limit_def
    proof (intro conjI allI impI)
      show "Ord (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        using Limit.hyps Limit_def Ord_in_Ord \<open>Ord \<beta>\<close> by (auto intro: Ord_Sup)
      have "succ 0 \<in> elts \<mu>"
        using Limit.hyps Limit_def by blast
      then show "0 \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        using False \<open>Ord \<beta>\<close> mem_0_Ord by force
      show "succ y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        if "y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))" for y
        using that False Limit.hyps
        apply (clarsimp simp: Limit_def)
        by (metis Ord_in_Ord Ord_linear Ord_mem_iff_lt Ord_mult Ord_succ assms(2) less_V_def mult_cancellation mult_succ not_add_mem_right succ_le_iff succ_ne_self)
    qed
    have "\<alpha>\<up>(\<beta> * (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)) = \<alpha>\<up>\<Squnion> ((*) \<beta> ` elts \<mu>)"
      by (simp add: mult_Sup_distrib)
    also have "\<dots> = \<Squnion> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
      using False Lim oexp_Limit by fastforce
    also have "\<dots> = (\<Squnion>x\<in>elts \<mu>. \<alpha>\<up>(\<beta> * x))"
    proof (rule Sup_eq_Sup)
      show "(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu> \<subseteq> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
        using \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
        apply clarsimp
        by (metis Limit_def elts_succ imageI insertI1 mem_0_Ord mult_add_mem_0)
      show "\<exists>y\<in>(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu>. x \<le> y"
        if "x \<in> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))" for x
        using that \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
        by clarsimp (metis Limit_def Ord_in_Ord Ord_mult VWO_TC_le mem_imp_VWO oexp_mono)
    qed auto
    also have "\<dots> = \<Squnion> ((\<up>) (\<alpha>\<up>\<beta>) ` elts (\<Squnion>\<xi>\<in>elts \<mu>. \<xi>))"
      using Limit.IH Limit.hyps by auto
    also have "\<dots> = (\<alpha>\<up>\<beta>)\<up>(\<Squnion>\<xi>\<in>elts \<mu>. \<xi>)"
      using False Limit.hyps oexp_Limit \<open>Ord \<beta>\<close> by auto
    finally show ?case .
  qed
qed

lemma Limit_omega_oexp:
  assumes "Ord \<delta>" "\<delta> \<noteq> 0"
  shows "Limit (\<omega>\<up>\<delta>)"
  using assms
proof (cases \<delta> rule: Ord_cases)
  case 0
  then show ?thesis
    using assms(2) by blast
next
  case (succ l)
  have *: "succ \<beta> \<in> elts (\<omega>\<up>l * n + \<omega>\<up>l)"
    if n: "n \<in> elts \<omega>" and \<beta>: "\<beta> \<in> elts (\<omega>\<up>l * n)" for n \<beta>
  proof -
    obtain "Ord n" "Ord \<beta>"
      by (meson Ord_\<omega> Ord_in_Ord Ord_mult Ord_oexp \<beta> n succ(1))
    obtain oo: "Ord (\<omega>\<up>l)" "Ord (\<omega>\<up>l * n)"
      by (simp add: \<open>Ord n\<close> succ(1))
    moreover have f4: "\<beta> < \<omega>\<up>l * n"
      using oo Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>\<beta> \<in> elts (\<omega>\<up>l * n)\<close> by blast
    moreover have f5: "Ord (succ \<beta>)"
      using \<open>Ord \<beta>\<close> by blast
    moreover have "\<omega>\<up>l \<noteq> 0"
      using oexp_eq_0_iff omega_nonzero succ(1) by blast
    ultimately show ?thesis
      by (metis add_less_cancel_left Ord_\<omega> Ord_add Ord_mem_iff_lt OrdmemD \<open>Ord \<beta>\<close> add.right_neutral dual_order.strict_trans2 oexp_gt_0_iff succ(1) succ_le_iff zero_in_omega)
  qed
  show ?thesis
    using succ
    apply (clarsimp simp: Limit_def mem_0_Ord)
    apply (simp add: mult_Limit)
    by (metis * mult_succ succ_in_omega)
next
  case limit
  then show ?thesis
    by (metis Limit_oexp Ord_\<omega> OrdmemD one_V_def succ_in_omega zero_in_omega)
qed

lemma oexp_mult_commute:
  fixes j::nat
  assumes "Ord \<alpha>"
  shows "(\<alpha> \<up> j) * \<alpha> = \<alpha> * (\<alpha> \<up> j)"
proof -
  have "(\<alpha> \<up> j) * \<alpha> = \<alpha> \<up> (1 + ord_of_nat j)"
    by (simp add: one_V_def)
  also have "... = \<alpha> * (\<alpha> \<up> j)"
    by (simp add: assms oexp_add)
  finally show ?thesis .
qed

lemma oexp_\<omega>_Limit: "Limit \<beta> \<Longrightarrow> \<omega>\<up>\<beta> = (\<Squnion>\<xi> \<in> elts \<beta>. \<omega>\<up>\<xi>)"
  by (simp add: oexp_Limit)

lemma \<omega>_power_succ_gtr: "Ord \<alpha> \<Longrightarrow> \<omega> \<up> \<alpha> * ord_of_nat n < \<omega> \<up> succ \<alpha>"
  by (simp add: OrdmemD)

lemma countable_oexp:
  assumes \<nu>: "\<alpha> \<in> elts \<omega>1"
  shows "\<omega> \<up> \<alpha> \<in> elts \<omega>1"
proof -
  have "Ord \<alpha>"
    using Ord_\<omega>1 Ord_in_Ord assms by blast
  then show ?thesis
    using assms
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by (simp add: Ord_mem_iff_lt)
  next
    case (succ \<alpha>)
    then have "countable (elts (\<omega> \<up> \<alpha> * \<omega>))"
      by (simp add: succ_in_Limit_iff countable_mult less_\<omega>1_imp_countable)
    then show ?case
      using Ord_mem_iff_lt countable_iff_less_\<omega>1 succ.hyps by auto
  next
    case (Limit \<alpha>)
    with Ord_\<omega>1 have "countable (\<Union>\<beta>\<in>elts \<alpha>. elts (\<omega> \<up> \<beta>))" "Ord (\<omega> \<up> \<Squnion> (elts \<alpha>))"
      by (force simp: Limit_def intro: Ord_trans less_\<omega>1_imp_countable)+
    then have "\<omega> \<up> \<Squnion> (elts \<alpha>) < \<omega>1"
      using Limit.hyps countable_iff_less_\<omega>1 oexp_Limit by fastforce
    then show ?case
      using Limit.hyps Limit_def Ord_mem_iff_lt by auto
  qed
qed

end


section \<open>Graph Theory Inheritance\<close>
text \<open> This theory aims to demonstrate the use of locales to transfer theorems between different
graph/combinatorial structure representations \<close>

theory Graph_Theory_Relations imports Undirected_Graph_Basics Bipartite_Graphs
"Design_Theory.Block_Designs" "Design_Theory.Group_Divisible_Designs"
begin

subsection \<open> Design Inheritance \<close>
text \<open>A graph is a type of incidence system, and more specifically a type of combinatorial design.
This section demonstrates the correspondence between designs and graphs \<close>

sublocale graph_system \<subseteq> inc: incidence_system V "mset_set E"
  by (unfold_locales) (metis wellformed elem_mset_set ex_in_conv infinite_set_mset_mset_set)

sublocale fin_graph_system \<subseteq> finc: finite_incidence_system V "mset_set E"
  using finV by unfold_locales

sublocale fin_ulgraph \<subseteq> d: design V "mset_set E"
  using edge_size empty_not_edge fin_edges by unfold_locales auto

sublocale fin_ulgraph \<subseteq> d: simple_design V "mset_set E"
  by unfold_locales (simp add: fin_edges)

locale graph_has_edges = graph_system +
  assumes edges_nempty: "E \<noteq> {}"

locale fin_sgraph_wedges = fin_sgraph + graph_has_edges

text \<open>The simple graph definition of degree overlaps with the definition of a point replication number \<close>
sublocale fin_sgraph_wedges \<subseteq> bd: block_design V "mset_set E" 2
  rewrites "point_replication_number (mset_set E) x = degree x"
    and "points_index (mset_set E) vs = degree_set vs"
proof (unfold_locales)
  show "inc.\<b> \<noteq> 0"  by (simp add: edges_nempty fin_edges)
  show "\<And>bl. bl \<in># mset_set E \<Longrightarrow> card bl = 2" by (simp add: fin_edges two_edges)
  show "mset_set E index vs = degree_set vs"
    unfolding degree_set_def points_index_def by (simp add: fin_edges)
next
  have "size {#b \<in># (mset_set E) . x \<in> b#} = card (incident_edges x)"
    unfolding incident_edges_def incident_def
    by (simp add: fin_edges)
  then show "mset_set E rep x = degree x" using alt_degree_def point_replication_number_def
    by metis
qed

locale fin_bipartite_graph_wedges = fin_bipartite_graph + fin_sgraph_wedges

sublocale fin_bipartite_graph_wedges \<subseteq> group_design V "mset_set E" "{X, Y}"
  by unfold_locales (simp_all add: partition ne)

subsection \<open>Adjacency Relation Definition \<close>

text \<open> Another common formal representation of graphs is as a vertex set and an adjacency relation
This is a useful representation in some contexts - we use locales to enable the transfer of
results between the two representations, specifically the mutual sublocales approach \<close>

locale graph_rel =
  fixes vertices :: "'a set" ("V")
  fixes adj_rel :: "'a rel"
  assumes wf: "\<And> u v. (u, v) \<in> adj_rel \<Longrightarrow> u \<in> V \<and> v \<in> V"
begin

abbreviation "adj u v \<equiv> (u, v) \<in> adj_rel"

lemma wf_alt: "adj u v \<Longrightarrow> (u, v) \<in> V \<times> V"
  using wf by blast

end

locale ulgraph_rel = graph_rel +
  assumes sym_adj: "sym adj_rel"
begin

text \<open> This definition makes sense in the context of an undirected graph \<close>
definition edge_set:: "'a edge set" where
"edge_set \<equiv> {{u, v} | u v. adj u v}"

lemma obtain_edge_pair_adj:
  assumes "e \<in> edge_set"
  obtains u v where "e = {u, v}" and "adj u v"
  using assms edge_set_def mem_Collect_eq
  by fastforce

lemma adj_to_edge_set_card:
  assumes "e \<in> edge_set"
  shows "card e = 1 \<or> card e = 2"
proof -
  obtain u v where "e = {u, v}" and "adj u v" using obtain_edge_pair_adj assms by blast
  then show ?thesis by (cases "u = v", simp_all)
qed

lemma adj_to_edge_set_card_lim:
  assumes "e \<in> edge_set"
  shows "card e > 0 \<and> card e \<le> 2"
proof -
  obtain u v where "e = {u, v}" and "adj u v" using obtain_edge_pair_adj assms by blast
  then show ?thesis by (cases "u = v", simp_all)
qed

lemma edge_set_wf: "e \<in> edge_set \<Longrightarrow> e \<subseteq> V"
  using obtain_edge_pair_adj wf by (metis insert_iff singletonD subsetI)

lemma is_graph_system: "graph_system V edge_set"
  by (unfold_locales) (simp add: edge_set_wf)

lemma sym_alt: "adj u v \<longleftrightarrow> adj v u"
  using sym_adj by (meson symE)

lemma is_ulgraph: "ulgraph V edge_set"
  using ulgraph_axioms_def is_graph_system adj_to_edge_set_card_lim
  by (intro_locales) auto

end

context ulgraph
begin

definition adj_relation :: "'a rel" where
"adj_relation \<equiv> {(u, v) | u v . vert_adj u v}"

lemma adj_relation_wf: "(u, v) \<in> adj_relation \<Longrightarrow> {u, v} \<subseteq> V"
  unfolding adj_relation_def using vert_adj_imp_inV by auto

lemma adj_relation_sym: "sym adj_relation"
  unfolding adj_relation_def sym_def using vert_adj_sym by auto

lemma is_ulgraph_rel: "ulgraph_rel V adj_relation"
  using adj_relation_wf adj_relation_sym by (unfold_locales) auto

text \<open> Temporary interpretation - mutual sublocale setup \<close>

interpretation ulgraph_rel V adj_relation by (rule is_ulgraph_rel)

lemma vert_adj_rel_iff:
  assumes "u \<in> V" "v \<in> V"
  shows "vert_adj u v \<longleftrightarrow> adj u v"
  using adj_relation_def by auto

lemma edges_rel_is: "E = edge_set"
proof -
  have "E = {{u, v} | u v . vert_adj u v}"
  proof (intro subset_antisym subsetI)
    show "\<And>x. x \<in> {{u, v} |u v. vert_adj u v} \<Longrightarrow> x \<in> E"
      using vert_adj_def by fastforce
  next
    fix x assume "x \<in> E"
    then have "x \<subseteq> V" and "card x > 0" and "card x \<le> 2" using wellformed edge_size by auto
    then obtain u v where "x = {u, v}" and "{u, v} \<in> E"
      by (metis \<open>x \<in> E\<close> alt_edge_size card_1_singletonE card_2_iff insert_absorb2)
    then show "x \<in> {{u, v} |u v. vert_adj u v}" unfolding vert_adj_def by blast
  qed
  then have "E = {{u, v} | u v . adj u v}" using vert_adj_rel_iff Collect_cong
    by (smt (verit) local.wf vert_adj_imp_inV)
  thus ?thesis using edge_set_def by simp
qed

end

context ulgraph_rel
begin

text \<open> Temporary interpretation - mutual sublocale setup \<close>
interpretation ulgraph V edge_set by (rule is_ulgraph)

lemma rel_vert_adj_iff:  "vert_adj u v \<longleftrightarrow> adj u v"
proof (intro iffI)
  assume "vert_adj u v"
  then have "{u, v} \<in> edge_set" by (simp add: vert_adj_def)
  then show "adj u v" using edge_set_def
    by (metis (no_types, lifting) doubleton_eq_iff obtain_edge_pair_adj sym_alt)
next
  assume "adj u v"
  then have "{u, v} \<in> edge_set" using edge_set_def by auto
  then show "vert_adj u v" by (simp add: vert_adj_def)
qed

lemma rel_item_is: "(u, v) \<in> adj_rel \<longleftrightarrow> (u, v) \<in> adj_relation"
  unfolding adj_relation_def using rel_vert_adj_iff by auto

lemma rel_edges_is: "adj_rel = adj_relation"
  using rel_item_is by auto

end

sublocale ulgraph_rel \<subseteq> ulgraph "V" "edge_set"
  rewrites "ulgraph.adj_relation edge_set = adj_rel"
  using local.is_ulgraph rel_edges_is by simp_all

sublocale ulgraph \<subseteq> ulgraph_rel "V" "adj_relation"
  rewrites "ulgraph_rel.edge_set adj_relation = E"
  using is_ulgraph_rel edges_rel_is by simp_all

locale sgraph_rel = ulgraph_rel +
  assumes irrefl_adj: "irrefl adj_rel"
begin

lemma irrefl_alt: "adj u v \<Longrightarrow> u \<noteq> v"
  using irrefl_adj irrefl_def by fastforce

lemma edge_is_card2:
  assumes "e \<in> edge_set"
  shows "card e = 2"
proof -
  obtain u v where eq: "e = {u, v}" and "adj u v" using assms edge_set_def by blast
  then have "u \<noteq> v" using irrefl_alt by simp
  thus ?thesis using eq by simp
qed

lemma is_sgraph: "sgraph V edge_set"
  using is_graph_system edge_is_card2 sgraph_axioms_def by (intro_locales) auto

end

context sgraph
begin

lemma is_rel_irrefl_alt:
  assumes "(u, v) \<in> adj_relation"
  shows "u \<noteq> v"
proof -
  have "vert_adj u v" using adj_relation_def assms by blast
  then have "{u, v} \<in> E" using vert_adj_def by simp
  then have "card {u, v} = 2" using two_edges by simp
  thus ?thesis by auto
qed

lemma is_rel_irrefl: "irrefl adj_relation"
  using irrefl_def is_rel_irrefl_alt by auto

lemma is_sgraph_rel: "sgraph_rel V adj_relation"
  by (unfold_locales) (simp add: is_rel_irrefl)

end

sublocale sgraph_rel \<subseteq> sgraph V "edge_set"
  rewrites "ulgraph.adj_relation edge_set = adj_rel"
  using is_sgraph rel_edges_is by simp_all

sublocale sgraph \<subseteq> sgraph_rel V "adj_relation"
  rewrites "ulgraph_rel.edge_set adj_relation = E"
  using is_sgraph_rel edges_rel_is by simp_all

end


(* Author: Tobias Nipkow & Stefan Dirix *)

section \<open>Weight Balanced Tree Implementation of Sets\<close>

text \<open>This theory follows Hirai and Yamamoto but we do not prove their general
theorem. Instead we provide a short parameterized theory that, when
interpreted with valid parameters, will prove perservation of the invariant
for these parameters.\<close>

theory Weight_Balanced_Trees
imports
  "HOL-Data_Structures.Isin2"
begin

lemma neq_Leaf2_iff: "t \<noteq> Leaf \<longleftrightarrow> (\<exists>l a n r. t = Node l (a,n) r)"
by(cases t) auto

type_synonym 'a wbt = "('a * nat) tree"

fun size_wbt :: "'a wbt \<Rightarrow> nat" where
"size_wbt Leaf = 0" |
"size_wbt (Node _ (_, n) _) = n"

text \<open>Smart constructor:\<close>

fun N :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"N l a r = Node l (a, size_wbt l + size_wbt r + 1) r"

text "Basic Rotations:"

fun rot1L :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot1L A a B b C = N (N A a B) b C"

fun rot1R :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot1R A a B b C = N A a (N B b C)"

fun rot2 :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot2 A a (Node B1 (b,_) B2) c C = N (N A a B1) b (N B2 c C)"

subsection "WB trees"

text \<open>
Parameters:
  \<^descr> \<open>\<Delta>\<close> determines when a tree needs to be rebalanced
  \<^descr> \<open>\<Gamma>\<close> determines whether it needs to be single or double rotation.

\noindent We represent rational numbers as pairs: \<open>\<Delta> = \<Delta>1/\<Delta>2\<close> and \<open>\<Gamma> = \<Gamma>1/\<Gamma>2\<close>.
\bigskip

Hirai and Yamamoto \<^cite>\<open>"HiraiY11"\<close> proved that under the following constraints
insertion and deletion preserve the WB invariant, i.e.\
\<open>\<Delta>\<close> and \<open>\<Gamma>\<close> are \emph{valid}:\<close>

definition valid_params :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"valid_params \<Delta>1 \<Delta>2 \<Gamma>1 \<Gamma>2 = (
  \<Delta>1 * 2 < \<Delta>2 * 9  \<comment> \<open>right: \<open>\<Delta> < 4.5\<close>\<close> \<and>
  \<Gamma>1 * \<Delta>2 + \<Gamma>2 * \<Delta>2 \<le> \<Gamma>2 * \<Delta>1 \<comment> \<open>left: \<open>\<Gamma> + 1 \<le> \<Delta>\<close>\<close> \<and>
  \<Gamma>1 * \<Delta>1 \<ge> \<Gamma>2 * (\<Delta>1 + \<Delta>2)  \<comment> \<open>lower: \<open>\<Gamma> \<ge> (\<Delta> + 1) / \<Delta>\<close>\<close> \<and>
  \<comment> \<open>upper:\<close>
  (5*\<Delta>2 \<le> 2*\<Delta>1 \<and> 1*\<Delta>1 < 3*\<Delta>2 \<longrightarrow> \<Gamma>1*2 \<le> \<Gamma>2*3)
     \<comment> \<open>\<open>\<Gamma> \<le> 3/2\<close> if \<open>2.5 \<le> \<Delta> < 3\<close>\<close> \<and>
  (3*\<Delta>2 \<le> 1*\<Delta>1 \<and> 2*\<Delta>1 < 7*\<Delta>2 \<longrightarrow> \<Gamma>1*2 \<le> \<Gamma>2*4)
     \<comment> \<open>\<open>\<Gamma> \<le> 4/2\<close> if \<open>3 \<le> \<Delta> < 3.5\<close>\<close> \<and>
  (7*\<Delta>2 \<le> 2*\<Delta>1 \<and> 1*\<Delta>1 < 4*\<Delta>2 \<longrightarrow> \<Gamma>1*3 \<le> \<Gamma>2*4)
     \<comment> \<open>\<open>\<Gamma> \<le> 4/3\<close> when \<open>3.5 \<le> \<Delta> < 4\<close>\<close> \<and>
  (4*\<Delta>2 \<le> 1*\<Delta>1 \<and> 2*\<Delta>1 < 9*\<Delta>2 \<longrightarrow> \<Gamma>1*3 \<le> \<Gamma>2*5)
     \<comment> \<open>\<open>\<Gamma> \<le> 5/3\<close> when \<open>4 \<le> \<Delta> < 4.5\<close>\<close>
  )"

text \<open>We do not make use of these constraints and do not prove that they guarantee
preservation of the invariant. Instead, we provide generic proofs of invariant preservation
that work for many (all?) interpretations of locale \<open>WBT\<close> (below) with valid parameters.
Further down we demonstrate this by interpreting \<open>WBT\<close> with a selection of valid parameters.
[For some parameters, some \<open>smt\<close> proofs fail because \<open>smt\<close> on \<open>nat\<close>s fails although
on non-negative \<open>int\<close>s it succeeds, i.e.\ the goal should be provable.
This is a shortcoming of \<open>smt\<close> that is under investigation.]

Locale \<open>WBT\<close> comes with some minimal assumptions (\<open>\<Gamma>1 > \<Gamma>2\<close> and \<open>\<Delta>1 > \<Delta>2\<close>) which follow
from @{const valid_params} and from which we conclude some simple lemmas.
\<close>

locale WBT =
fixes \<Delta>1 \<Delta>2 :: nat and \<Gamma>1 \<Gamma>2 :: nat
assumes Delta_gr1: "\<Delta>1 > \<Delta>2" and Gamma_gr1: "\<Gamma>1 > \<Gamma>2"
begin

(* How to prove the assumptions from valid_params:
lemma Gamma_gr1: "\<Gamma>1 > \<Gamma>2"
proof -
  have "\<not> (\<Delta>1 + \<Delta>2) * \<Gamma>2 \<le> \<Delta>1 * \<Gamma>2" by (simp add: not0)
  thus ?thesis by (metis order.trans lower mult.commute mult_le_cancel2 not_le)
qed

lemma Delta_gr2: "\<Delta>1 > 2 * \<Delta>2"
proof -
  from Gamma_gr1 have "\<Gamma>2 * \<Delta>2 < \<Gamma>1 * \<Delta>2" by (simp add: not0)
  with left have "2 * \<Gamma>2 * \<Delta>2 < \<Gamma>2 * \<Delta>1" by linarith
  thus ?thesis by(simp)
qed
*)

subsubsection "Balance Indicators"

fun balanced1 :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> bool" where
"balanced1 t1 t2 = (\<Delta>1 * (size_wbt t1 + 1) \<ge> \<Delta>2 * (size_wbt t2 + 1))"

text \<open>The global weight-balanced tree invariant:\<close>

fun wbt :: "'a wbt \<Rightarrow> bool" where
"wbt Leaf = True"|
"wbt (Node l (_, n) r) =
  (n = size l + size r + 1 \<and> balanced1 l r \<and> balanced1 r l \<and> wbt l \<and> wbt r)"

lemma size_wbt_eq_size[simp]: "wbt t \<Longrightarrow> size_wbt t = size t"
by(induction t) auto

fun single :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> bool" where
"single t1 t2 = (\<Gamma>1 * (size_wbt t2 + 1) > \<Gamma>2 * (size_wbt t1 + 1))"

subsubsection "Code"

fun rotateL :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rotateL A a (Node B (b, _) C) =
   (if single B C then rot1L A a B b C else rot2 A a B b C)"

fun balanceL :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"balanceL l a r = (if balanced1 l r then N l a r else rotateL l a r)"

fun rotateR :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rotateR (Node A (a, _) B) b C =
  (if single B A then rot1R A a B b C else rot2 A a B b C)"

fun balanceR :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"balanceR l a r = (if balanced1 r l then N l a r else rotateR l a r)"

fun insert :: "'a::linorder \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"insert x Leaf = Node Leaf (x, 1) Leaf" |
"insert x (Node l (a, n) r) =
   (case cmp x a of
      LT \<Rightarrow> balanceR (insert x l) a r |
      GT \<Rightarrow> balanceL l a (insert x r) |
      EQ \<Rightarrow> Node l (a, n) r )"

fun split_min :: "'a wbt \<Rightarrow> 'a * 'a wbt" where
"split_min (Node l (a, _) r) =
   (if l = Leaf then (a,r) else let (x,l') = split_min l in (x, balanceL l' a r))"

fun del_max :: "'a wbt \<Rightarrow> 'a * 'a wbt" where
"del_max (Node l (a, _) r) =
   (if r = Leaf then (a,l) else let (x,r') = del_max r in (x, balanceR l a r'))"

fun combine :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt"  where
"combine Leaf Leaf = Leaf"|
"combine Leaf r = r"|
"combine l Leaf = l"|
"combine l r =
   (if size l > size r then
      let (lMax, l') = del_max l in balanceL l' lMax r
    else
      let (rMin, r') = split_min r in balanceR l rMin r')"

fun delete :: "'a::linorder \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"delete _ Leaf = Leaf" |
"delete x (Node l (a, _) r) =
  (case cmp x a of
     LT \<Rightarrow> balanceL (delete x l) a r |
     GT \<Rightarrow> balanceR l a (delete x r) |
     EQ \<Rightarrow> combine l r)"

subsection "Functional Correctness Proofs"

text \<open>A WB tree must be of a certain structure if balanced1 and single are False.\<close>

lemma not_Leaf_if_not_balanced1:
  assumes "\<not> balanced1 l r"
  shows "r \<noteq> Leaf"
proof
  assume "r = Leaf" with assms Delta_gr1 show False by simp
qed

lemma not_Leaf_if_not_single:
  assumes "\<not> single l r"
  shows "l \<noteq> Leaf"
proof
  assume "l = Leaf" with assms Gamma_gr1 show False by simp
qed

subsubsection "Inorder Properties"

lemma inorder_rotateL:
  "r \<noteq> Leaf \<Longrightarrow> inorder(rotateL l a r) = inorder l @ a # inorder r"
by (induction l a r rule: rotateL.induct) (auto simp add: inorder_rot2 not_Leaf_if_not_single)

lemma inorder_rotateR:
  "l \<noteq> Leaf \<Longrightarrow> inorder(rotateR l a r) = inorder l @ a # inorder r"
by (induction l a r rule: rotateR.induct) (auto simp add: inorder_rot2 not_Leaf_if_not_single)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by (induction t)
   (auto simp: ins_list_simps inorder_rotateL inorder_rotateR not_Leaf_if_not_balanced1)

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by (induction t arbitrary: t' rule: split_min.induct)
   (auto simp: sorted_lems inorder_rotateL not_Leaf_if_not_balanced1
     split: prod.splits if_splits)

lemma del_maxD:
  "del_max t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> inorder t' @ [x] = inorder t"
by (induction t arbitrary: t' rule: del_max.induct)
   (auto simp: sorted_lems inorder_rotateR not_Leaf_if_not_balanced1
     split: prod.splits if_splits)

lemma inorder_combine:
  "inorder(combine l r) = inorder l @ inorder r"
by(induction l r rule: combine.induct)
  (auto simp: del_maxD split_minD inorder_rotateL inorder_rotateR not_Leaf_if_not_balanced1
    simp del: rotateL.simps rotateR.simps split: prod.splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_combine inorder_rotateL inorder_rotateR
     not_Leaf_if_not_balanced1 simp del: rotateL.simps rotateR.simps)

subsection "Size Lemmas"

subsubsection "Insertion"

lemma size_rot2L[simp]:
  "B \<noteq> Leaf \<Longrightarrow> size(rot2 A a B b C) = size A + size B + size C + 2"
by(induction A a B b C rule: rot2.induct) auto

lemma size_rotateR[simp]:
  "l \<noteq> Leaf \<Longrightarrow> size(rotateR l a r) = size l + size r + 1"
by(induction l a r rule: rotateR.induct)
  (auto simp: not_Leaf_if_not_single simp del: rot2.simps)

lemma size_rotateL[simp]:
  "r \<noteq> Leaf \<Longrightarrow> size(rotateL l a r) = size l + size r + 1"
by(induction l a r rule: rotateL.induct)
  (auto simp: not_Leaf_if_not_single simp del: rot2.simps)

lemma size_length: "size t = length (inorder t)"
by (induction t rule: inorder.induct) auto

lemma size_insert: "size (insert x t) = (if isin t x then size t else Suc (size t))"
by (induction t rule: tree2_induct) (auto simp: not_Leaf_if_not_balanced1)

subsubsection "Deletion"

lemma size_delete_if_isin: "isin t x \<Longrightarrow> size t = Suc (size(delete x t))"
proof (induction t rule: tree2_induct)
  case (Node _ a _ _)
  thus ?case
  proof (cases "cmp x a")
    case LT thus ?thesis using Node.prems by (simp add: Node.IH(1) not_Leaf_if_not_balanced1)
  next
    case EQ thus ?thesis by simp (metis size_length inorder_combine length_append)
  next
    case GT thus ?thesis using Node.prems by (simp add: Node.IH(2) not_Leaf_if_not_balanced1)
  qed
qed (auto)

lemma delete_id_if_wbt_notin: "wbt t \<Longrightarrow> \<not> isin t x \<Longrightarrow> delete x t = t"
by (induction t) auto

lemma size_split_min: "t \<noteq> Leaf \<Longrightarrow> size t = Suc (size (snd (split_min t)))"
by(induction t) (auto simp: not_Leaf_if_not_balanced1 split: if_splits prod.splits)

subsection "Auxiliary Definitions"

fun balanced1_arith :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"balanced1_arith a b = (\<Delta>1 * (a + 1) \<ge> \<Delta>2 * (b + 1))"

fun balanced2_arith :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"balanced2_arith a b = (balanced1_arith a b \<and> balanced1_arith b a)"

fun singly_balanced_arith :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"singly_balanced_arith x y w = (balanced2_arith x y \<and> balanced2_arith (x+y+1) w)"

fun doubly_balanced_arith :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"doubly_balanced_arith x y z w =
  (balanced2_arith x y \<and> balanced2_arith z w \<and> balanced2_arith (x+y+1) (z+w+1))"

end

subsection "Preservation of WB tree Invariant for Concrete Parameters"

text \<open>A number of sample interpretations with valid parameters:\<close>

interpretation WBT where
  \<Delta>1 = 25 and \<Delta>2 = 10 and \<Gamma>1 = 14 and \<Gamma>2 = 10
(* \<Delta>1 = 25 and \<Delta>2 = 10 and \<Gamma>1 = 15 and \<Gamma>2 = 10*)
(* \<Delta>1 = 28 and \<Delta>2 = 10 and \<Gamma>1 = 10 and \<Gamma>2 = 7*)

(* \<Delta>1 = 3 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 4 and \<Gamma>2 = 3*)
  (* The only integer solution: *)
(* \<Delta>1 = 3 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 2 and \<Gamma>2 = "Suc 0"*)
(* \<Delta>1 = 31 and \<Delta>2 = 10 and \<Gamma>1 = 18 and \<Gamma>2 = 10*)

(* \<Delta>1 = 35 and \<Delta>2 = 10 and \<Gamma>1 = 45 and \<Gamma>2 = 35*)
(* \<Delta>1 = 35 and \<Delta>2 = 10 and \<Gamma>1 = 4 and \<Gamma>2 = 3*)
(* \<Delta>1 = 37 and \<Delta>2 = 10 and \<Gamma>1 = 13 and \<Gamma>2 = 10*)

(* \<Delta>1 = 4 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 5 and \<Gamma>2 = 4*)
(* \<Delta>1 = 4 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 5 and \<Gamma>2 = 3*)
(* \<Delta>1 = 17 and \<Delta>2 = 4 and \<Gamma>1 = 5 and \<Gamma>2 = 3 *)
by (auto simp add: WBT_def)

lemma wbt_insert:
  "wbt t \<Longrightarrow> wbt (insert x t)"
proof (induction t rule: tree2_induct)
  case Leaf show ?case by simp
next
  case (Node l a _ r)
  show ?case
  proof (cases "cmp x a")
    case EQ thus ?thesis using Node.prems by auto
  next
    case [simp]: LT
    let ?l' = "insert x l"
    show ?thesis
    proof (cases "balanced1 r ?l'")
      case True thus ?thesis using Node size_insert[of x l] by auto
    next
      case [simp]: False
      hence "?l' \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
      then obtain k ll' al' rl' where [simp]: "?l' = (Node ll' (al', k) rl')"
        by(meson neq_Leaf2_iff)
      show ?thesis
      proof (cases "single rl' ll'")
        case True thus ?thesis using Node size_insert[of x l]
          by (auto split: if_splits)
      next
        case isDouble: False
        then obtain k llr' alr' rlr' where [simp]: "rl' = (Node llr' (alr', k) rlr')"
          using not_Leaf_if_not_single tree2_cases by blast
        show ?thesis using isDouble Node size_insert[of x l]
          by (auto split: if_splits)
      qed
    qed
  next
    case [simp]: GT
    let ?r' = "insert x r"
    show ?thesis
    proof (cases "balanced1 l ?r'")
      case True thus ?thesis using Node size_insert[of x r] by auto
    next
      case [simp]: False
      hence "?r' \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
      then obtain k lr' ar' rr' where [simp]: "?r' = (Node lr' (ar', k) rr')"
        by(meson neq_Leaf2_iff)
      show ?thesis
      proof (cases "single lr' rr'")
        case True thus ?thesis using Node size_insert[of x r]
          by (auto split: if_splits)
      next
        case isDouble: False
        hence "lr' \<noteq> Leaf" using not_Leaf_if_not_single by auto
        thus ?thesis
          using Node isDouble size_insert[of x r]
          by (auto simp: neq_Leaf2_iff split: if_splits)
      qed
    qed
  qed
qed

declare [[smt_nat_as_int]]

text \<open>
  Show that invariant is preserved by deletion in the left/right subtree:
\<close>

lemma wbt_balanceL:
  assumes "wbt (Node l (a, n) r)" "wbt l'" "size l = size l' + 1"
  shows "wbt (balanceL l' a' r)"
proof -
  have rl'Balanced: "balanced1 r l'" using assms by auto
  have rBalanced: "wbt r" using assms(1) by simp
  show ?thesis
  proof (cases "balanced1 l' r")
    case True thus ?thesis using assms(2) rBalanced rl'Balanced by auto
  next
    case notBalanced: False
    hence "r \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
    then obtain k lr ar rr where [simp]: "r = Node lr (ar, k) rr" by(meson neq_Leaf2_iff)
    show ?thesis
    proof (cases "single lr rr")
      case single: True
      have "singly_balanced_arith (size l') (size lr) (size rr)"
        using assms(1) notBalanced rl'Balanced rBalanced single assms
        by (simp) (smt?)
      thus ?thesis using notBalanced single assms(2) rBalanced by simp
    next
      case isDouble: False
      hence "lr \<noteq> Leaf" using not_Leaf_if_not_single by auto
      then obtain k2 llr alr rlr where [simp]: "lr = (Node llr (alr, k2) rlr)"
        by(meson neq_Leaf2_iff)
      have "doubly_balanced_arith (size l') (size llr) (size rlr) (size rr)"
        using assms(1) notBalanced rl'Balanced rBalanced isDouble assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using notBalanced isDouble assms(2) rBalanced by simp
    qed
  qed
qed

lemma wbt_balanceR:
  assumes "wbt (Node l (a, n) r)" "wbt r'" "size r = size r' + 1"
  shows "wbt (balanceR l a' r')"
proof -
  have lr'Balanced: "balanced1 l r'" using assms by auto
  have lBalanced: "wbt l" using assms(1) by simp
  show ?thesis
  proof (cases "balanced1 r' l")
    case True thus ?thesis using assms(2) lBalanced lr'Balanced by simp
  next
    case notBalanced: False
    hence "l \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
    then obtain k ll al rl where [simp]: "l = (Node ll (al, k) rl)" by(meson neq_Leaf2_iff)
    show ?thesis
    proof (cases "single rl ll")
      case single: True
      have "singly_balanced_arith (size rl) (size r') (size ll)"
        using assms(1) notBalanced lr'Balanced lBalanced single assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using assms(2) lBalanced notBalanced single by simp
    next
      case isDouble: False
      hence "rl \<noteq> Leaf" using not_Leaf_if_not_single by auto
      then obtain k lrl arl rrl where [simp]: "rl = (Node lrl (arl, k) rrl)"
        by(meson neq_Leaf2_iff)
      have "doubly_balanced_arith (size ll) (size lrl) (size rrl) (size r')"
        using assms(1) notBalanced lr'Balanced lBalanced isDouble assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using assms(2) lBalanced notBalanced isDouble by simp
    qed
  qed
qed

lemma wbt_split_min: "t \<noteq> Leaf \<Longrightarrow> wbt t \<Longrightarrow> wbt (snd (split_min t))"
proof (induction t rule: split_min.induct)
  case (1 l a m r)
  show ?case
  proof (cases l rule: tree2_cases)
    case Leaf thus ?thesis using "1.prems"(2) by simp
  next
    case (Node ll al n rl)
    let ?l' = "snd (split_min (Node ll (al, n) rl))"
    have delBalanceL: "snd (split_min (Node l (a, m) r)) = balanceL ?l' a r"
      using Node by(auto split: prod.splits)
    have "wbt ?l'" using "1"(1) "1.prems"(2) Node by auto
    moreover have "size l = size ?l' + 1"
      using Node size_split_min by (metis Suc_eq_plus1 neq_Leaf2_iff)
    ultimately have "wbt (balanceL ?l' a r)"
      by (meson "1.prems"(2) wbt_balanceL)
    thus ?thesis using delBalanceL by auto
  qed
qed (blast)

lemma wbt_del_max: "t \<noteq> Leaf \<Longrightarrow> wbt t \<Longrightarrow> wbt (snd (del_max t))"
proof (induction t rule: del_max.induct)
  case (1 l a m r)
  show ?case
  proof (cases r rule: tree2_cases)
    case Leaf thus ?thesis using "1.prems"(2) by simp
  next
    case (Node lr ar n rr)
    then obtain r' where delMaxR: "r' = snd (del_max (Node lr (ar, n) rr))"
      by simp
    hence delBalanceR: "snd (del_max (Node l (a, m) r)) = balanceR l a r'"
      using Node by(auto split: prod.splits)
    have "wbt r'" using "1"(1) "1.prems"(2) Node delMaxR by auto
    moreover have "size r = size r' + 1" using size_del_max Node delMaxR
      by (metis Suc_eq_plus1 tree.simps(3))
    ultimately have "wbt (balanceR l a r')"
      using wbt_balanceR by (metis "1.prems"(2))
    thus ?thesis using delBalanceR by auto
  qed
qed (blast)

lemma wbt_delete: "wbt t \<Longrightarrow> wbt (delete x t)"
proof (induction t rule: tree2_induct)
  case Leaf thus ?case by simp
next
  case (Node l a n r)
  show ?case
  proof (cases "isin (Node l (a, n) r) x")
    case False thus ?thesis using Node.prems delete_id_if_wbt_notin by metis
  next
    case isin: True
    thus ?thesis
    proof (cases "cmp x a")
      case LT
      let ?l' = "delete x l"
      have "size l = size ?l' + 1"
        using LT isin by (auto simp: size_delete_if_isin)
      hence "wbt (balanceL ?l' a r)"
        using Node.IH(1) Node.prems by (fastforce intro: wbt_balanceL)
      thus ?thesis by (simp add: LT)
    next
      case GT
      let ?r' = "delete x r"
      have "wbt ?r'" using Node.IH(2) Node.prems by simp
      moreover have "size r = size ?r' + 1"
        using GT Node.prems isin size_delete_if_isin by auto
      ultimately have "wbt (balanceR l a ?r')"
        by (meson Node.prems wbt_balanceR)
      thus ?thesis by (simp add: GT)
    next
      case [simp]: EQ
      hence xCombine: "delete x (Node l (a, n) r) = combine l r" by simp
      {
        assume "l = Leaf" "r = Leaf" hence ?thesis by simp
      }
      moreover
      {
        assume "l = Leaf" "r \<noteq> Leaf"
        hence ?thesis using Node.prems by (auto simp: neq_Leaf2_iff)
      }
      moreover
      {
        assume "l \<noteq> Leaf" "r = Leaf"
        hence ?thesis using Node.prems by (auto simp: neq_Leaf2_iff)
      }
      moreover
      {
        assume lrNotLeaf: "l \<noteq> Leaf" "r \<noteq> Leaf"
        then obtain kl kr ll al rl lr ar rr
          where [simp]: "l = (Node ll (al, kl) rl)" "r = (Node lr (ar, kr) rr)"
          by (meson neq_Leaf2_iff)
        have ?thesis
        proof (cases "size l > size r")
          case True
          obtain lMax l' where letMax: "del_max l = (lMax, l')"
            by (metis prod.exhaust)
          hence balanceLeft: "combine l r = balanceL l' lMax r"
            using \<open>size l > size r\<close> by (simp)
          have "wbt l'"
            using Node.prems wbt_del_max[OF lrNotLeaf(1)] letMax
            by (metis wbt.simps(2) snd_conv)
          moreover have "size l = size l' + 1"
            using size_del_max[OF lrNotLeaf(1)] letMax by (simp)
          ultimately have "wbt(balanceL l' lMax r)"
            using wbt_balanceL by (metis Node.prems)
          thus ?thesis using balanceLeft by simp
        next
          case False
          obtain rMin r' where letMin: "split_min r = (rMin, r')"
            by (metis prod.exhaust)
          hence balanceRight: "combine l r = balanceR l rMin r'"
            using \<open>\<not> size l > size r\<close> by (simp)
          have "wbt r'"
            using Node.prems wbt_split_min[OF lrNotLeaf(2)] letMin
            by (metis wbt.simps(2) snd_conv)
          moreover have "size r = size r' + 1"
            using size_split_min[OF lrNotLeaf(2)] letMin by simp
          ultimately have "wbt(balanceR l rMin r')"
            using wbt_balanceR by (metis Node.prems)
          thus ?thesis using balanceRight by simp
        qed
      }
      ultimately show ?thesis by blast
    qed
  qed
qed

subsection \<open>The final correctness proof\<close>

interpretation S: Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = wbt
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 show ?case by simp
next
  case 6 thus ?case using wbt_insert by blast
next
  case 7 thus ?case using wbt_delete by blast
qed

end