theory SetTheory1
imports Main
begin

lemma "A = B \<Longrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
proof (rule conjI)
  assume "A = B"
  thus "A \<subseteq> B" by (rule equalityD1)
 next
  assume "A = B"
  thus "B \<subseteq> A" by (rule equalityD2)
qed

lemma helper : " A \<subset> B \<and> B \<subset> A  \<Longrightarrow> A = B"
proof (rule subset_antisym)
  assume a:"A \<subset> B \<and> B \<subset> A"
  hence b:"A \<subset> B" ..
  thus "A \<subseteq> B"  by simp
next
  assume "A \<subset> B \<and> B \<subset> A"
  hence "B \<subset> A" ..
  thus "B \<subseteq> A" by simp
qed

lemma "A \<subset> B \<Longrightarrow> A \<subseteq> B" by simp

    (*this one is non sensical*)
lemma helper2 : "(\<forall>x. (x \<in> A \<longleftrightarrow> x \<in> B)) \<Longrightarrow> (A = B)"
proof -
  assume a:"\<forall>x. (x \<in> A) = (x \<in> B)"
  {
    assume "A \<noteq> B"
    from this obtain y where b:"y \<in> A  \<and> y \<notin> B" using a by auto
    hence c:"y \<in> A" ..
    from b have d:"y \<notin> B" ..
    from a have "(y \<in> A) = (y \<in> B)" by (rule allE)
    with d and c have False by simp
  }
  hence "\<not> (A \<noteq> B)" by (rule notI)
  thus ?thesis by simp
qed

lemma "\<forall>x. (x \<in> A) \<longleftrightarrow> (x \<in> B) \<Longrightarrow> (A = B)"
proof -
  assume "\<forall>x. (x \<in> A) \<longleftrightarrow> (x \<in> B)"
  hence "\<And>y. (y \<in> A) \<longleftrightarrow> (y \<in> B)" by (rule allE)
  hence "{y. y \<in> A} = {y . y \<in> B}" by simp
  thus "A = B" by simp
qed

lemma "A \<inter> B = {x . x \<in> A \<and>  x \<in> B}" by (rule Int_def)

lemma "A \<noteq> B  \<Longrightarrow> \<exists>y. y \<in> A  \<and> y \<notin> B \<or> y \<notin> A \<and> y \<in> B  "
proof -
  assume a:"A \<noteq> B"
  {
    assume b:"\<not>(\<exists>y. y \<in> A  \<and> y \<notin> B \<or> y \<notin> A \<and> y \<in> B)"
    {
      fix y
      from b have  "(y \<in> A \<longrightarrow> y \<in> B)  \<and> ((y \<in> A) \<or> (y \<notin> B))" by simp
      hence "(y \<in> A \<longrightarrow> y \<in> B)  \<and> (y \<in> B \<longrightarrow> y \<in> A)" by auto
      hence "y \<in> A \<longleftrightarrow> y \<in> B" by auto
    }
    hence "\<forall>y. y \<in> A \<longleftrightarrow> y \<in> B" by (rule allI)
    hence "{y. y \<in> A} = {y. y \<in> B}" by simp
    hence "A = B" by simp
    with a have False by contradiction
  }
  thus "\<exists>y. y \<in> A  \<and> y \<notin> B \<or> y \<notin> A \<and> y \<in> B" by auto
qed

lemma "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)" by blast

lemma "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
proof -
  {
    fix x
    have "(x \<in> (A \<inter> (B \<union> C))) =  (x \<in> A \<and> x \<in> (B \<union> C))" by simp
    also have "\<dots> = (x \<in> A \<and> (x \<in> B \<or> x \<in> C))" by simp
    also have "\<dots> = ((x \<in> A \<and> x \<in> B) \<or> (x \<in> A \<and> x \<in> C))"
    proof -
      have "(x \<in> A \<and> (x \<in> B \<or> x \<in> C)) \<Longrightarrow> (x \<in> A \<and> x \<in> B \<or> x \<in> A \<and> x \<in> C)" by simp
      moreover
      {
        assume "x \<in> A \<and> x \<in> B \<or> x \<in> A \<and> x \<in> C"
        hence "x \<in> A \<and> (x \<in> B \<or> x \<in> C)" by blast
      }
      ultimately show ?thesis by (rule iffI)
    qed
    also have "\<dots> = (x \<in> (A \<inter> B) \<or> x \<in> (A \<inter> C))" by simp
    also have "\<dots> = (x \<in> ((A \<inter> B) \<union> (A \<inter> C)))" by simp
    finally have "(x \<in> (A \<inter> (B \<union> C))) = (x \<in> ((A \<inter> B) \<union> (A \<inter> C)))" by assumption
  }
  hence "\<forall>x. (x \<in> (A \<inter> (B \<union> C))) = (x \<in> (A \<inter> B) \<union> (A \<inter> C))" by (rule allI)
  thus ?thesis by (simp add : helper2)
qed

lemma "A \<subset> B \<Longrightarrow> B \<subset> C \<Longrightarrow> A \<subset> C" by (rule order.strict_trans)

lemma "A \<subseteq> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> A \<subseteq> C"
proof -
  assume a:"A \<subseteq> B"
  assume b:"B \<subseteq> C"
  show ?thesis
  proof (cases "A = B")
    case True
    assume "A = B"
    with b show ?thesis by simp
  next
    case False
    assume "A \<noteq> B"
    with a have c:"A \<subset> B" by simp
    then show ?thesis
    proof (cases "B = C")
      case True
      with c have "A \<subset> C" by simp
      then show ?thesis by simp
    next
      case False
      with b have "B \<subset> C" by simp
      with c show ?thesis by simp
    qed
  qed
qed

lemma "A \<subseteq> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> C \<subseteq> A \<Longrightarrow> A = B \<and>  B = C \<and> C = A"
proof -
  assume a:"A \<subseteq> B"
  assume b:"B \<subseteq> C"
  assume c:"C \<subseteq> A"
  from a and b have "A \<subseteq> C" by simp
  with c have d:"A = C" by simp
  with a and b have e:"A = B" by simp
  with d have "B = C" by simp
  with d and e show ?thesis by simp
qed

lemma "{x. False}= {}"
proof -
  have "{x . False} = (if False then UNIV else {})" unfolding Collect_const by (rule subst; rule refl)
  also have "\<dots> = {}" by simp
  finally show ?thesis by assumption
qed

lemma "A \<inter> B = A - (A - B)" by blast

lemma "A \<inter> B = A - (A - B)"
proof -
  {
    assume "A \<inter> B"

lemma "A \<in> \<A> \<Longrightarrow> B \<in> \<A> \<Longrightarrow> "

lemma "\<exists>x. x \<in> {n::nat . n \<noteq> 5}"
  using [[simp_trace_new mode=full]]
proof -
  obtain y::nat where "y \<noteq> (5::nat)"
  proof -
    assume a:"\<And>y. y \<noteq> (5::nat) \<Longrightarrow> thesis"
      thus thesis using one_eq_numeral_iff by blast

lemma "A \<noteq> {} = (\<exists>x . x \<in> A)"
proof -
  {
    assume "A \<noteq> {}"

lemma "\<exists>x. x \<in> A \<Longrightarrow> card A > 0"
proof -
  assume "\<exists>x . x \<in> A"
  {
    assume "card A \<le> 0"
    hence "card A = 0" by simp
        hence "A = {}"

lemma "A = {} \<Longrightarrow> \<forall>x. x \<notin> A"
proof (rule allI)
  fix x
  assume "A = {}"

lemma "A = {} = (\<forall>x. x \<notin> A)"
proof -
  {
    assume a:"A = {}"
    hence b:"card A = 0" by simp
    {
      assume c:"\<exists>x. x \<in> A"
      {
        fix x
        assume "x \<in> A"
        with a have False by simp
      }
      with c have False by (rule exE)
    }
    hence "\<forall>x. x \<notin> A" by auto
  }
  moreover
  {
    assume "\<forall>x. x \<notin> A"
    {

lemma helper3: "B \<noteq> {} = (\<exists>x. x \<in> B)"
proof -
  {
    assume a:"B \<noteq> {}"
    {
      assume "\<not>(\<exists>x. x \<in> B)"
      hence "B = {}" by simp
      with a have False by contradiction
    }
    hence "\<not>\<not>(\<exists>x. x \<in> B)" by (rule notI)
    hence "\<exists>x. x \<in> B" by (rule notnotD)
  }
  moreover
  {
    assume a:"\<exists>x. x \<in> B"
    {
      assume "B = {}"
      hence "\<forall>x. x \<notin> B" by (subst all_not_in_conv)
      hence "\<not>(\<exists>x. x \<in> B)" by simp
      with a have False by contradiction
    }
    hence "B \<noteq> {}" by auto
  }
    ultimately show ?thesis by (rule iffI)
qed

lemma "A \<inter> B = {} \<Longrightarrow> \<exists>x. x \<in> A \<and> x \<notin> B \<or> x \<notin> A \<and> x \<in> B \<or> A = {} \<and> B = {}"
  using [[simp_trace_new mode=full]]
proof -
  assume "A \<inter> B = {}"
  show ?thesis
  proof (cases "A = {}")
    case True
    assume a:"A = {}"
    then show ?thesis
    proof (cases "B = {}")
      case True
      with a  show ?thesis by simp
    next
      case False
      assume b:"B \<noteq> {}"
      from b have  "(\<exists>x. x \<in> A \<and> x \<notin> B \<or> x \<notin> A \<and> x \<in> B \<or> A = {} \<and> B = {}) = (\<exists>x. x \<in> A \<and> x \<notin> B \<or> x \<notin> A \<and> x \<in> B \<or> False)" by simp
      also from a have "\<dots> = (\<exists>x. False \<or> x \<notin> A \<and> x \<in> B)" by simp
      also have "\<dots> = (\<exists>x. x \<notin> A \<and> x \<in> B)" by simp
      also from a have "\<dots> = (\<exists>x. True \<and> x \<in> B)" by simp
      also have "\<dots> = (\<exists>x. x \<in> B)" by simp
      also have "\<dots> = (B \<noteq> {})" unfolding helper3  by (rule subst; rule refl)
      finally show ?thesis using b by simp
    qed
  next
    case False
    assume a:"A \<noteq> {}"
    then show ?thesis
    proof (cases "B = {}")
      case True
      with a show ?thesis by auto
    next
      case False

      then show ?thesis sorry
    qed

  qed

lemma "A \<inter> B = {} \<Longrightarrow> card(A \<union> B) = card A + card B"
proof -
  assume a:"A \<inter> B = {}"
  {
    assume "card(A \<union> B) \<noteq> card A + card B"

lemma "card (a:: 'a set) + card (b::'a set)  \<ge> card (a \<union> b)"
proof (cases "a \<inter> b = {}")
  case True
  then show ?thesis
next
  case False
  then show ?thesis sorry
qed

lemma "A \<union> B = A \<inter> -B \<union> A \<inter> B \<union> -A \<inter> B"
proof -
  {
    fix x
    assume "x \<in> (A \<union> B)"


section \<open>Challenge 3\<close>
theory Challenge3
  imports Parallel_Multiset_Fold Refine_Imperative_HOL.IICF
begin

text \<open>Problem definition:
\<^url>\<open>https://ethz.ch/content/dam/ethz/special-interest/infk/chair-program-method/pm/documents/Verify%20This/Challenges%202019/sparse_matrix_multiplication.pdf\<close>\<close>

subsection \<open>Single-Threaded Implementation\<close>
text \<open>We define type synonyms for values (which we fix to integers here) and
  triplets, which are a pair of coordinates and a value.
\<close>
type_synonym val = int
type_synonym triplet = "(nat \<times> nat) \<times> val"

text \<open>We fix a size \<open>n\<close> for the vector.\<close>
context
  fixes n :: nat
begin

  text \<open>An algorithm finishing triples in any order.
  \<close>
  definition
    "alg (ts :: triplet list) x = fold_mset (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) (\<lambda>_. 0 :: int) (mset ts)"

  text \<open>
    We show that the folding function is commutative, i.e., the order of the folding does not matter.
    We will use this below to show that the computation can be parallelized.
  \<close>
  interpretation comp_fun_commute "(\<lambda>((r, c), v) y. y(c := (y c :: val) + x r * v))"
    apply unfold_locales
    apply (auto intro!: ext)
    done

  subsection \<open>Specification\<close>
  text \<open>Abstraction function, mapping a sparse matrix to a function from coordinates to values.\<close>
  definition \<alpha> :: "triplet list \<Rightarrow> (nat \<times> nat) \<Rightarrow> val" where
    "\<alpha> = the_default 0 oo map_of"

  text \<open>Abstract product.\<close>
  definition "pr m x i \<equiv> \<Sum>k=0..<n. x k * m (k, i)"

  subsection \<open>Correctness\<close>

  lemma aux:
    "
    distinct (map fst (ts1@ts2)) \<Longrightarrow>
    the_default (0::val) (case map_of ts1 (k, i) of None \<Rightarrow> map_of ts2 (k, i) | Some x \<Rightarrow> Some x)

    = the_default 0 (map_of ts1 (k, i)) + the_default 0 (map_of ts2 (k, i))
    "
    apply (auto split: option.splits)
    by (metis disjoint_iff_not_equal img_fst map_of_eq_None_iff the_default.simps(2))

  lemma 1[simp]: "distinct (map fst (ts1@ts2)) \<Longrightarrow>
    pr (\<alpha> (ts1@ts2)) x i = pr (\<alpha> ts1) x i + pr (\<alpha> ts2) x i"
    apply (auto simp: pr_def \<alpha>_def map_add_def aux split: option.splits)
    apply (auto simp: algebra_simps)
    by (simp add: sum.distrib)

  lemmas 2 = 1[of "[((r,c),v)]" "ts", simplified] for r c v ts

  lemma correct_fold:
    assumes "distinct (map fst ts)"
    assumes "\<forall>((r,c),_)\<in>set ts. r<n"
    shows "fold (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) ts (\<lambda>_. 0) = pr (\<alpha> ts) x"
    apply (rule ext)
    using correct_aux[OF assms, rule_format, where m = "\<lambda>_. 0", simplified]
    by simp

  lemma alg_by_fold: "alg ts x = fold (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) ts (\<lambda>_. 0)"
    unfolding alg_def by (simp add: fold_mset_rewr)

  theorem correct:
    assumes "distinct (map fst ts)"
    assumes "\<forall>((r,c),_)\<in>set ts. r<n"
    shows "alg ts x = pr (\<alpha> ts) x"
    using alg_by_fold correct_fold[OF assms] by simp

  subsection \<open>Multi-Threaded Implementation\<close>
  text \<open>Correctness of the parallel implementation:\<close>
  theorem parallel_correct:
    assumes "distinct (map fst ts)" "\<forall>((r,c),_)\<in>set ts. r<n"
        and "0 < n" \<comment> \<open>At least on thread\<close>
        \<comment>\<open>We have reached a final state.\<close>
        and "reachable x n ts (\<lambda>_. 0) (ts', ms, r)" "final n (ts', ms, r)"
      shows "r = pr (\<alpha> ts) x"
    unfolding final_state_correct[OF assms(3-)] correct[OF assms(1,2)] alg_by_fold[symmetric] ..

  text \<open>We also know that the computation will always terminate.\<close>
  theorem parallel_termination:
    assumes "0 < n"
      and "reachable x n ts (\<lambda>_. 0) s"
    shows "\<exists>s'. final n s' \<and> (step x n)\<^sup>*\<^sup>* s s'"
    using assms by (rule "termination")

end \<comment> \<open>Context for fixed \<open>n\<close>.\<close>

end


theory heap_SortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil2

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun merge :: "Heap => Heap => Heap" where
"merge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (merge x3 (Node x4 x5 x6)) x2 z else
      Node (merge (Node z x2 x3) x6) x5 x4)"
| "merge (Node z x2 x3) (Nil2) = Node z x2 x3"
| "merge (Nil2) y = y"

fun toList :: "Nat => Heap => Nat list" where
"toList (Z) y = Nil2"
| "toList (S z) (Node x2 x3 x4) =
     Cons2 x3 (toList z (merge x2 x4))"
| "toList (S z) (Nil2) = Nil2"

fun insert2 :: "Nat => Heap => Heap" where
"insert2 x y = merge (Node Nil2 x Nil2) y"

fun toHeap :: "Nat list => Heap" where
"toHeap (Nil2) = Nil2"
| "toHeap (Cons2 y xs) = insert2 y (toHeap xs)"

fun heapSize :: "Heap => Nat" where
"heapSize (Node l y r) = S (plus (heapSize l) (heapSize r))"
| "heapSize (Nil2) = Z"

fun toList2 :: "Heap => Nat list" where
"toList2 x = toList (heapSize x) x"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun hsort :: "Nat list => Nat list" where
"hsort x =
   dot (% (y :: Heap) => toList2 y) (% (z :: Nat list) => toHeap z) x"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "Nat list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (le y y2) (ordered (Cons2 y2 xs))"

(*hipster plus
          le
          merge
          toList
          insert2
          toHeap
          heapSize
          toList2
          dot
          hsort
          and2
          ordered *)

theorem x0 :
  "!! (x :: Nat list) . ordered (hsort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* Author: Tobias Nipkow, Daniel Stüwe *)

section {* Three-Way Comparison *}

theory Cmp
imports Main
begin

datatype cmp_val = LT | EQ | GT

definition cmp :: "'a:: linorder \<Rightarrow> 'a \<Rightarrow> cmp_val" where
"cmp x y = (if x < y then LT else if x=y then EQ else GT)"

lemma
    LT[simp]: "cmp x y = LT \<longleftrightarrow> x < y"
and EQ[simp]: "cmp x y = EQ \<longleftrightarrow> x = y"
and GT[simp]: "cmp x y = GT \<longleftrightarrow> x > y"
by (auto simp: cmp_def)

lemma case_cmp_if[simp]: "(case c of EQ \<Rightarrow> e | LT \<Rightarrow> l | GT \<Rightarrow> g) =
  (if c = LT then l else if c = GT then g else e)"
by(simp split: cmp_val.split)

end


(*  Title:      HOL/Library/Infinite_Set.thy
    Author:     Stephan Merz
*)

section \<open>Infinite Sets and Related Concepts\<close>

theory Infinite_Set
  imports Main
begin

subsection \<open>The set of natural numbers is infinite\<close>

lemma infinite_nat_iff_unbounded_le: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. n \<in> S)"
  for S :: "nat set"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_sequentially)

lemma infinite_nat_iff_unbounded: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n>m. n \<in> S)"
  for S :: "nat set"
  using frequently_cofinite[of "\<lambda>x. x \<in> S"]
  by (simp add: cofinite_eq_sequentially frequently_def eventually_at_top_dense)

lemma finite_nat_iff_bounded: "finite S \<longleftrightarrow> (\<exists>k. S \<subseteq> {..<k})"
  for S :: "nat set"
  using infinite_nat_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_iff_bounded_le: "finite S \<longleftrightarrow> (\<exists>k. S \<subseteq> {.. k})"
  for S :: "nat set"
  using infinite_nat_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

lemma finite_nat_bounded: "finite S \<Longrightarrow> \<exists>k. S \<subseteq> {..<k}"
  for S :: "nat set"
  by (simp add: finite_nat_iff_bounded)

text \<open>
  For a set of natural numbers to be infinite, it is enough to know
  that for any number larger than some \<open>k\<close>, there is some larger
  number that is an element of the set.
\<close>

lemma unbounded_k_infinite: "\<forall>m>k. \<exists>n>m. n \<in> S \<Longrightarrow> infinite (S::nat set)"
  apply (clarsimp simp add: finite_nat_set_iff_bounded)
  apply (drule_tac x="Suc (max m k)" in spec)
  using less_Suc_eq apply fastforce
  done

lemma nat_not_finite: "finite (UNIV::nat set) \<Longrightarrow> R"
  by simp

lemma range_inj_infinite:
  fixes f :: "nat \<Rightarrow> 'a"
  assumes "inj f"
  shows "infinite (range f)"
proof
  assume "finite (range f)"
  from this assms have "finite (UNIV::nat set)"
    by (rule finite_imageD)
  then show False by simp
qed

subsection \<open>The set of integers is also infinite\<close>

lemma infinite_int_iff_infinite_nat_abs: "infinite S \<longleftrightarrow> infinite ((nat \<circ> abs) ` S)"
  for S :: "int set"
proof (unfold Not_eq_iff, rule iffI)
  assume "finite ((nat \<circ> abs) ` S)"
  then have "finite (nat ` (abs ` S))"
    by (simp add: image_image cong: image_cong)
  moreover have "inj_on nat (abs ` S)"
    by (rule inj_onI) auto
  ultimately have "finite (abs ` S)"
    by (rule finite_imageD)
  then show "finite S"
    by (rule finite_image_absD)
qed simp

proposition infinite_int_iff_unbounded_le: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> \<ge> m \<and> n \<in> S)"
  for S :: "int set"
  by (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded_le o_def image_def)
    (metis abs_ge_zero nat_le_eq_zle le_nat_iff)

proposition infinite_int_iff_unbounded: "infinite S \<longleftrightarrow> (\<forall>m. \<exists>n. \<bar>n\<bar> > m \<and> n \<in> S)"
  for S :: "int set"
  by (simp add: infinite_int_iff_infinite_nat_abs infinite_nat_iff_unbounded o_def image_def)
    (metis (full_types) nat_le_iff nat_mono not_le)

proposition finite_int_iff_bounded: "finite S \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {..<k})"
  for S :: "int set"
  using infinite_int_iff_unbounded_le[of S] by (simp add: subset_eq) (metis not_le)

proposition finite_int_iff_bounded_le: "finite S \<longleftrightarrow> (\<exists>k. abs ` S \<subseteq> {.. k})"
  for S :: "int set"
  using infinite_int_iff_unbounded[of S] by (simp add: subset_eq) (metis not_le)

subsection \<open>Infinitely Many and Almost All\<close>

text \<open>
  We often need to reason about the existence of infinitely many
  (resp., all but finitely many) objects satisfying some predicate, so
  we introduce corresponding binders and their proof rules.
\<close>

lemma not_INFM [simp]: "\<not> (INFM x. P x) \<longleftrightarrow> (MOST x. \<not> P x)"
  by (rule not_frequently)

lemma not_MOST [simp]: "\<not> (MOST x. P x) \<longleftrightarrow> (INFM x. \<not> P x)"
  by (rule not_eventually)

lemma INFM_const [simp]: "(INFM x::'a. P) \<longleftrightarrow> P \<and> infinite (UNIV::'a set)"
  by (simp add: frequently_const_iff)

lemma MOST_const [simp]: "(MOST x::'a. P) \<longleftrightarrow> P \<or> finite (UNIV::'a set)"
  by (simp add: eventually_const_iff)

lemma INFM_imp_distrib: "(INFM x. P x \<longrightarrow> Q x) \<longleftrightarrow> ((MOST x. P x) \<longrightarrow> (INFM x. Q x))"
  by (rule frequently_imp_iff)

lemma MOST_imp_iff: "MOST x. P x \<Longrightarrow> (MOST x. P x \<longrightarrow> Q x) \<longleftrightarrow> (MOST x. Q x)"
  by (auto intro: eventually_rev_mp eventually_mono)

lemma INFM_conjI: "INFM x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> INFM x. P x \<and> Q x"
  by (rule frequently_rev_mp[of P]) (auto elim: eventually_mono)

text \<open>Properties of quantifiers with injective functions.\<close>

lemma INFM_inj: "INFM x. P (f x) \<Longrightarrow> inj f \<Longrightarrow> INFM x. P x"
  using finite_vimageI[of "{x. P x}" f] by (auto simp: frequently_cofinite)

lemma MOST_inj: "MOST x. P x \<Longrightarrow> inj f \<Longrightarrow> MOST x. P (f x)"
  using finite_vimageI[of "{x. \<not> P x}" f] by (auto simp: eventually_cofinite)

text \<open>Properties of quantifiers with singletons.\<close>

lemma not_INFM_eq [simp]:
  "\<not> (INFM x. x = a)"
  "\<not> (INFM x. a = x)"
  unfolding frequently_cofinite by simp_all

lemma MOST_neq [simp]:
  "MOST x. x \<noteq> a"
  "MOST x. a \<noteq> x"
  unfolding eventually_cofinite by simp_all

lemma INFM_neq [simp]:
  "(INFM x::'a. x \<noteq> a) \<longleftrightarrow> infinite (UNIV::'a set)"
  "(INFM x::'a. a \<noteq> x) \<longleftrightarrow> infinite (UNIV::'a set)"
  unfolding frequently_cofinite by simp_all

lemma MOST_eq [simp]:
  "(MOST x::'a. x = a) \<longleftrightarrow> finite (UNIV::'a set)"
  "(MOST x::'a. a = x) \<longleftrightarrow> finite (UNIV::'a set)"
  unfolding eventually_cofinite by simp_all

lemma MOST_eq_imp:
  "MOST x. x = a \<longrightarrow> P x"
  "MOST x. a = x \<longrightarrow> P x"
  unfolding eventually_cofinite by simp_all

text \<open>Properties of quantifiers over the naturals.\<close>

lemma MOST_nat: "(\<forall>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<exists>m. \<forall>n>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded_le subset_eq simp flip: not_le)

lemma MOST_nat_le: "(\<forall>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<exists>m. \<forall>n\<ge>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (auto simp add: eventually_cofinite finite_nat_iff_bounded subset_eq simp flip: not_le)

lemma INFM_nat: "(\<exists>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<forall>m. \<exists>n>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded)

lemma INFM_nat_le: "(\<exists>\<^sub>\<infinity>n. P n) \<longleftrightarrow> (\<forall>m. \<exists>n\<ge>m. P n)"
  for P :: "nat \<Rightarrow> bool"
  by (simp add: frequently_cofinite infinite_nat_iff_unbounded_le)

lemma MOST_INFM: "infinite (UNIV::'a set) \<Longrightarrow> MOST x::'a. P x \<Longrightarrow> INFM x::'a. P x"
  by (simp add: eventually_frequently)

lemma MOST_Suc_iff: "(MOST n. P (Suc n)) \<longleftrightarrow> (MOST n. P n)"
  by (simp add: cofinite_eq_sequentially)

lemma MOST_SucI: "MOST n. P n \<Longrightarrow> MOST n. P (Suc n)"
  and MOST_SucD: "MOST n. P (Suc n) \<Longrightarrow> MOST n. P n"
  by (simp_all add: MOST_Suc_iff)

lemma MOST_ge_nat: "MOST n::nat. m \<le> n"
  by (simp add: cofinite_eq_sequentially)

\<comment> \<open>legacy names\<close>
lemma Inf_many_def: "Inf_many P \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma Alm_all_def: "Alm_all P \<longleftrightarrow> \<not> (INFM x. \<not> P x)" by simp
lemma INFM_iff_infinite: "(INFM x. P x) \<longleftrightarrow> infinite {x. P x}" by (fact frequently_cofinite)
lemma MOST_iff_cofinite: "(MOST x. P x) \<longleftrightarrow> finite {x. \<not> P x}" by (fact eventually_cofinite)
lemma INFM_EX: "(\<exists>\<^sub>\<infinity>x. P x) \<Longrightarrow> (\<exists>x. P x)" by (fact frequently_ex)
lemma ALL_MOST: "\<forall>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x" by (fact always_eventually)
lemma INFM_mono: "\<exists>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<exists>\<^sub>\<infinity>x. Q x" by (fact frequently_elim1)
lemma MOST_mono: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_mono)
lemma INFM_disj_distrib: "(\<exists>\<^sub>\<infinity>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>\<^sub>\<infinity>x. P x) \<or> (\<exists>\<^sub>\<infinity>x. Q x)" by (fact frequently_disj_iff)
lemma MOST_rev_mp: "\<forall>\<^sub>\<infinity>x. P x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. P x \<longrightarrow> Q x \<Longrightarrow> \<forall>\<^sub>\<infinity>x. Q x" by (fact eventually_rev_mp)
lemma MOST_conj_distrib: "(\<forall>\<^sub>\<infinity>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>\<^sub>\<infinity>x. P x) \<and> (\<forall>\<^sub>\<infinity>x. Q x)" by (fact eventually_conj_iff)
lemma MOST_conjI: "MOST x. P x \<Longrightarrow> MOST x. Q x \<Longrightarrow> MOST x. P x \<and> Q x" by (fact eventually_conj)
lemma INFM_finite_Bex_distrib: "finite A \<Longrightarrow> (INFM y. \<exists>x\<in>A. P x y) \<longleftrightarrow> (\<exists>x\<in>A. INFM y. P x y)" by (fact frequently_bex_finite_distrib)
lemma MOST_finite_Ball_distrib: "finite A \<Longrightarrow> (MOST y. \<forall>x\<in>A. P x y) \<longleftrightarrow> (\<forall>x\<in>A. MOST y. P x y)" by (fact eventually_ball_finite_distrib)
lemma INFM_E: "INFM x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> thesis) \<Longrightarrow> thesis" by (fact frequentlyE)
lemma MOST_I: "(\<And>x. P x) \<Longrightarrow> MOST x. P x" by (rule eventuallyI)
lemmas MOST_iff_finiteNeg = MOST_iff_cofinite

subsection \<open>Enumeration of an Infinite Set\<close>

text \<open>The set's element type must be wellordered (e.g. the natural numbers).\<close>

text \<open>
  Could be generalized to
    \<^prop>\<open>enumerate' S n = (SOME t. t \<in> s \<and> finite {s\<in>S. s < t} \<and> card {s\<in>S. s < t} = n)\<close>.
\<close>

primrec (in wellorder) enumerate :: "'a set \<Rightarrow> nat \<Rightarrow> 'a"
  where
    enumerate_0: "enumerate S 0 = (LEAST n. n \<in> S)"
  | enumerate_Suc: "enumerate S (Suc n) = enumerate (S - {LEAST n. n \<in> S}) n"

lemma enumerate_Suc': "enumerate S (Suc n) = enumerate (S - {enumerate S 0}) n"
  by simp

lemma enumerate_in_set: "infinite S \<Longrightarrow> enumerate S n \<in> S"
proof (induct n arbitrary: S)
  case 0
  then show ?case
    by (fastforce intro: LeastI dest!: infinite_imp_nonempty)
next
  case (Suc n)
  then show ?case
    by simp (metis DiffE infinite_remove)
qed

declare enumerate_0 [simp del] enumerate_Suc [simp del]

lemma enumerate_step: "infinite S \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
proof (induction n arbitrary: S)
  case 0
  then have "enumerate S 0 \<le> enumerate S (Suc 0)"
    by (simp add: enumerate_0 Least_le enumerate_in_set)
  moreover have "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}"
    by (meson "0.prems" enumerate_in_set infinite_remove)
  then have "enumerate S 0 \<noteq> enumerate (S - {enumerate S 0}) 0"
    by auto
  ultimately show ?case
    by (simp add: enumerate_Suc')
next
  case (Suc n)
  then show ?case
    by (simp add: enumerate_Suc')
qed

lemma enumerate_mono: "m < n \<Longrightarrow> infinite S \<Longrightarrow> enumerate S m < enumerate S n"
  by (induct m n rule: less_Suc_induct) (auto intro: enumerate_step)

lemma enumerate_mono_iff [simp]:
  "infinite S \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
  by (metis enumerate_mono less_asym less_linear)

lemma enumerate_mono_le_iff [simp]:
  "infinite S \<Longrightarrow> enumerate S m \<le> enumerate S n \<longleftrightarrow> m \<le> n"
  by (meson enumerate_mono_iff not_le)

lemma le_enumerate:
  assumes S: "infinite S"
  shows "n \<le> enumerate S n"
  using S
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "n \<le> enumerate S n" by simp
  also note enumerate_mono[of n "Suc n", OF _ \<open>infinite S\<close>]
  finally show ?case by simp
qed

lemma infinite_enumerate:
  assumes fS: "infinite S"
  shows "\<exists>r::nat\<Rightarrow>nat. strict_mono r \<and> (\<forall>n. r n \<in> S)"
  unfolding strict_mono_def
  using enumerate_in_set[OF fS] enumerate_mono[of _ _ S] fS by blast

lemma enumerate_Suc'':
  fixes S :: "'a::wellorder set"
  assumes "infinite S"
  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
  using assms
proof (induct n arbitrary: S)
  case 0
  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
    by (auto simp: enumerate.simps intro: Least_le)
  then show ?case
    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
    by (intro arg_cong[where f = Least] ext) auto
next
  case (Suc n S)
  show ?case
    using enumerate_mono[OF zero_less_Suc \<open>infinite S\<close>, of n] \<open>infinite S\<close>
    apply (subst (1 2) enumerate_Suc')
    apply (subst Suc)
     apply (use \<open>infinite S\<close> in simp)
    apply (intro arg_cong[where f = Least] ext)
    apply (auto simp flip: enumerate_Suc')
    done
qed

lemma enumerate_Ex:
  fixes S :: "nat set"
  assumes S: "infinite S"
    and s: "s \<in> S"
  shows "\<exists>n. enumerate S n = s"
  using s
proof (induct s rule: less_induct)
  case (less s)
  show ?case
  proof (cases "\<exists>y\<in>S. y < s")
    case True
    let ?y = "Max {s'\<in>S. s' < s}"
    from True have y: "\<And>x. ?y < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
      by (subst Max_less_iff) auto
    then have y_in: "?y \<in> {s'\<in>S. s' < s}"
      by (intro Max_in) auto
    with less.hyps[of ?y] obtain n where "enumerate S n = ?y"
      by auto
    with S have "enumerate S (Suc n) = s"
      by (auto simp: y less enumerate_Suc'' intro!: Least_equality)
    then show ?thesis by auto
  next
    case False
    then have "\<forall>t\<in>S. s \<le> t" by auto
    with \<open>s \<in> S\<close> show ?thesis
      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
  qed
qed

lemma inj_enumerate:
  fixes S :: "'a::wellorder set"
  assumes S: "infinite S"
  shows "inj (enumerate S)"
  unfolding inj_on_def
proof clarsimp
  show "\<And>x y. enumerate S x = enumerate S y \<Longrightarrow> x = y"
    by (metis neq_iff enumerate_mono[OF _ \<open>infinite S\<close>])
qed

text \<open>To generalise this, we'd need a condition that all initial segments were finite\<close>
lemma bij_enumerate:
  fixes S :: "nat set"
  assumes S: "infinite S"
  shows "bij_betw (enumerate S) UNIV S"
proof -
  have "\<forall>s \<in> S. \<exists>i. enumerate S i = s"
    using enumerate_Ex[OF S] by auto
  moreover note \<open>infinite S\<close> inj_enumerate
  ultimately show ?thesis
    unfolding bij_betw_def by (auto intro: enumerate_in_set)
qed

lemma
  fixes S :: "nat set"
  assumes S: "infinite S"
  shows range_enumerate: "range (enumerate S) = S"
    and strict_mono_enumerate: "strict_mono (enumerate S)"
  by (auto simp add: bij_betw_imp_surj_on bij_enumerate assms strict_mono_def)

text \<open>A pair of weird and wonderful lemmas from HOL Light.\<close>
lemma finite_transitivity_chain:
  assumes "finite A"
    and R: "\<And>x. \<not> R x x" "\<And>x y z. \<lbrakk>R x y; R y z\<rbrakk> \<Longrightarrow> R x z"
    and A: "\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> A \<and> R x y"
  shows "A = {}"
  using \<open>finite A\<close> A
proof (induct A)
  case empty
  then show ?case by simp
next
  case (insert a A)
  have False
    using R(1)[of a] R(2)[of _ a] insert(3,4) by blast
  thus ?case ..
qed

corollary Union_maximal_sets:
  assumes "finite \<F>"
  shows "\<Union>{T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} = \<Union>\<F>"
    (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs" by force
  show "?rhs \<subseteq> ?lhs"
  proof (rule Union_subsetI)
    fix S
    assume "S \<in> \<F>"
    have "{T \<in> \<F>. S \<subseteq> T} = {}"
      if "\<not> (\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y)"
    proof -
      have \<section>: "\<And>x. x \<in> \<F> \<and> S \<subseteq> x \<Longrightarrow> \<exists>y. y \<in> \<F> \<and> S \<subseteq> y \<and> x \<subset> y"
        using that by (blast intro: dual_order.trans psubset_imp_subset)
      show ?thesis
      proof (rule finite_transitivity_chain [of _ "\<lambda>T U. S \<subseteq> T \<and> T \<subset> U"])
      qed (use assms in \<open>auto intro: \<section>\<close>)
    qed
    with \<open>S \<in> \<F>\<close> show "\<exists>y. y \<in> {T \<in> \<F>. \<forall>U\<in>\<F>. \<not> T \<subset> U} \<and> S \<subseteq> y"
      by blast
  qed
qed

subsection \<open>Properties of @{term enumerate} on finite sets\<close>

lemma finite_enumerate_in_set: "\<lbrakk>finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S n \<in> S"
proof (induction n arbitrary: S)
  case 0
  then show ?case
    by (metis all_not_in_conv card.empty enumerate.simps(1) not_less0 wellorder_Least_lemma(1))
next
  case (Suc n)
  show ?case
    using Suc.prems Suc.IH [of "S - {LEAST n. n \<in> S}"]
    apply (simp add: enumerate.simps)
    by (metis Diff_empty Diff_insert0 Suc_lessD card.remove less_Suc_eq)
qed

lemma finite_enumerate_step: "\<lbrakk>finite S; Suc n < card S\<rbrakk> \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
proof (induction n arbitrary: S)
  case 0
  then have "enumerate S 0 \<le> enumerate S (Suc 0)"
    by (simp add: Least_le enumerate.simps(1) finite_enumerate_in_set)
  moreover have "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}"
    by (metis 0 Suc_lessD Suc_less_eq card_Suc_Diff1 enumerate_in_set finite_enumerate_in_set)
  then have "enumerate S 0 \<noteq> enumerate (S - {enumerate S 0}) 0"
    by auto
  ultimately show ?case
    by (simp add: enumerate_Suc')
next
  case (Suc n)
  then show ?case
    by (simp add: enumerate_Suc' finite_enumerate_in_set)
qed

lemma finite_enumerate_mono: "\<lbrakk>m < n; finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n"
  by (induct m n rule: less_Suc_induct) (auto intro: finite_enumerate_step)

lemma finite_enumerate_mono_iff [simp]:
  "\<lbrakk>finite S; m < card S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
  by (metis finite_enumerate_mono less_asym less_linear)

lemma finite_le_enumerate:
  assumes "finite S" "n < card S"
  shows "n \<le> enumerate S n"
  using assms
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "n \<le> enumerate S n" by simp
  also note finite_enumerate_mono[of n "Suc n", OF _ \<open>finite S\<close>]
  finally show ?case
    using Suc.prems(2) Suc_leI by blast
qed

lemma finite_enumerate:
  assumes fS: "finite S"
  shows "\<exists>r::nat\<Rightarrow>nat. strict_mono_on {..<card S} r \<and> (\<forall>n<card S. r n \<in> S)"
  unfolding strict_mono_def
  using finite_enumerate_in_set[OF fS] finite_enumerate_mono[of _ _ S] fS
  by (metis lessThan_iff strict_mono_on_def)

lemma finite_enumerate_Suc'':
  fixes S :: "'a::wellorder set"
  assumes "finite S" "Suc n < card S"
  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
  using assms
proof (induction n arbitrary: S)
  case 0
  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
    by (auto simp: enumerate.simps intro: Least_le)
  then show ?case
    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
    by (metis Diff_iff dual_order.strict_iff_order singletonD singletonI)
next
  case (Suc n S)
  then have "Suc n < card (S - {enumerate S 0})"
    using Suc.prems(2) finite_enumerate_in_set by force
  then show ?case
    apply (subst (1 2) enumerate_Suc')
    apply (simp add: Suc)
    apply (intro arg_cong[where f = Least] HOL.ext)
    using finite_enumerate_mono[OF zero_less_Suc \<open>finite S\<close>, of n] Suc.prems
    by (auto simp flip: enumerate_Suc')
qed

lemma finite_enumerate_initial_segment:
  fixes S :: "'a::wellorder set"
  assumes "finite S" and n: "n < card (S \<inter> {..<s})"
  shows "enumerate (S \<inter> {..<s}) n = enumerate S n"
  using n
proof (induction n)
  case 0
  have "(LEAST n. n \<in> S \<and> n < s) = (LEAST n. n \<in> S)"
  proof (rule Least_equality)
    have "\<exists>t. t \<in> S \<and> t < s"
      by (metis "0" card_gt_0_iff disjoint_iff_not_equal lessThan_iff)
    then show "(LEAST n. n \<in> S) \<in> S \<and> (LEAST n. n \<in> S) < s"
      by (meson LeastI Least_le le_less_trans)
  qed (simp add: Least_le)
  then show ?case
    by (auto simp: enumerate_0)
next
  case (Suc n)
  then have less_card: "Suc n < card S"
    by (meson assms(1) card_mono inf_sup_ord(1) leD le_less_linear order.trans)
  obtain T where T: "T \<in> {s \<in> S. enumerate S n < s}"
    by (metis Infinite_Set.enumerate_step enumerate_in_set finite_enumerate_in_set finite_enumerate_step less_card mem_Collect_eq)
  have "(LEAST x. x \<in> S \<and> x < s \<and> enumerate S n < x) = (LEAST x. x \<in> S \<and> enumerate S n < x)"
       (is "_ = ?r")
  proof (intro Least_equality conjI)
    show "?r \<in> S"
      by (metis (mono_tags, lifting) LeastI mem_Collect_eq T)
    have "\<not> s \<le> ?r"
      using not_less_Least [of _ "\<lambda>x. x \<in> S \<and> enumerate S n < x"] Suc assms
      by (metis (mono_tags, lifting) Int_Collect Suc_lessD finite_Int finite_enumerate_in_set finite_enumerate_step lessThan_def less_le_trans)
    then show "?r < s"
      by auto
    show "enumerate S n < ?r"
      by (metis (no_types, lifting) LeastI mem_Collect_eq T)
  qed (auto simp: Least_le)
  then show ?case
    using Suc assms by (simp add: finite_enumerate_Suc'' less_card)
qed

lemma finite_enumerate_Ex:
  fixes S :: "'a::wellorder set"
  assumes S: "finite S"
    and s: "s \<in> S"
  shows "\<exists>n<card S. enumerate S n = s"
  using s S
proof (induction s arbitrary: S rule: less_induct)
  case (less s)
  show ?case
  proof (cases "\<exists>y\<in>S. y < s")
    case True
    let ?T = "S \<inter> {..<s}"
    have "finite ?T"
      using less.prems(2) by blast
    have TS: "card ?T < card S"
      using less.prems by (blast intro: psubset_card_mono [OF \<open>finite S\<close>])
    from True have y: "\<And>x. Max ?T < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
      by (subst Max_less_iff) (auto simp: \<open>finite ?T\<close>)
    then have y_in: "Max ?T \<in> {s'\<in>S. s' < s}"
      using Max_in \<open>finite ?T\<close> by fastforce
    with less.IH[of "Max ?T" ?T] obtain n where n: "enumerate ?T n = Max ?T" "n < card ?T"
      using \<open>finite ?T\<close> by blast
    then have "Suc n < card S"
      using TS less_trans_Suc by blast
    with S n have "enumerate S (Suc n) = s"
      by (subst finite_enumerate_Suc'') (auto simp: y finite_enumerate_initial_segment less finite_enumerate_Suc'' intro!: Least_equality)
    then show ?thesis
      using \<open>Suc n < card S\<close> by blast
  next
    case False
    then have "\<forall>t\<in>S. s \<le> t" by auto
    moreover have "0 < card S"
      using card_0_eq less.prems by blast
    ultimately show ?thesis
      using \<open>s \<in> S\<close>
      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
  qed
qed

lemma finite_enum_subset:
  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X \<le> card Y"
  shows "X \<subseteq> Y"
  by (metis assms finite_enumerate_Ex finite_enumerate_in_set less_le_trans subsetI)

lemma finite_enum_ext:
  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X = card Y"
  shows "X = Y"
  by (intro antisym finite_enum_subset) (auto simp: assms)

lemma finite_bij_enumerate:
  fixes S :: "'a::wellorder set"
  assumes S: "finite S"
  shows "bij_betw (enumerate S) {..<card S} S"
proof -
  have "\<And>n m. \<lbrakk>n \<noteq> m; n < card S; m < card S\<rbrakk> \<Longrightarrow> enumerate S n \<noteq> enumerate S m"
    using finite_enumerate_mono[OF _ \<open>finite S\<close>] by (auto simp: neq_iff)
  then have "inj_on (enumerate S) {..<card S}"
    by (auto simp: inj_on_def)
  moreover have "\<forall>s \<in> S. \<exists>i<card S. enumerate S i = s"
    using finite_enumerate_Ex[OF S] by auto
  moreover note \<open>finite S\<close>
  ultimately show ?thesis
    unfolding bij_betw_def by (auto intro: finite_enumerate_in_set)
qed

lemma ex_bij_betw_strict_mono_card:
  fixes M :: "'a::wellorder set"
  assumes "finite M"
  obtains h where "bij_betw h {..<card M} M" and "strict_mono_on {..<card M} h"
proof
  show "bij_betw (enumerate M) {..<card M} M"
    by (simp add: assms finite_bij_enumerate)
  show "strict_mono_on {..<card M} (enumerate M)"
    by (simp add: assms finite_enumerate_mono strict_mono_on_def)
qed

end


chapter {* R4: Cuantificadores sobre listas *}

theory R4_Cuantificadores_sobre_listas
imports Main
begin

text {*
  ---------------------------------------------------------------------
  Ejercicio 1. Definir la función
     todos :: ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (todos p xs) se verifica si todos los elementos de la lista
  xs cumplen la propiedad p. Por ejemplo, se verifica
     todos (\<lambda>x. 1<length x) [[2,1,4],[1,3]]
     \<not>todos (\<lambda>x. 1<length x) [[2,1,4],[3]]

  Nota: La función todos es equivalente a la predefinida list_all.
  ---------------------------------------------------------------------
*}

fun todos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "todos p [] = True"
| "todos p (x#xs) = (p x \<and> todos p xs)"

text {*
  ---------------------------------------------------------------------
  Ejercicio 2. Definir la función
     algunos :: ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (algunos p xs) se verifica si algunos elementos de la lista
  xs cumplen la propiedad p. Por ejemplo, se verifica
     algunos (\<lambda>x. 1<length x) [[2,1,4],[3]]
     \<not>algunos (\<lambda>x. 1<length x) [[],[3]]"

  Nota: La función algunos es equivalente a la predefinida list_ex.
  ---------------------------------------------------------------------
*}

fun algunos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
   "algunos p []     = False"
| "algunos p (x#xs) = (p x \<or> algunos p xs)"

text {*
  ---------------------------------------------------------------------
  Ejercicio 3.1. Demostrar o refutar automáticamente
     todos (\<lambda>x. P x \<and> Q x) xs = (todos P xs \<and> todos Q xs)
  ---------------------------------------------------------------------
*}

lemma "todos (\<lambda>x. P x \<and> Q x) xs = (todos P xs \<and> todos Q xs)"
by (induct xs) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 3.2. Demostrar o refutar detalladamente
     todos (\<lambda>x. P x \<and> Q x) xs = (todos P xs \<and> todos Q xs)
  ---------------------------------------------------------------------
*}

lemma "todos (\<lambda>x. P x \<and> Q x) xs = (todos P xs \<and> todos Q xs)"
proof (induct xs)
  show "todos (\<lambda>x. P x \<and> Q x) [] = (todos P [] \<and> todos Q [])" by simp
next
  fix a xs
  assume HI: "todos (\<lambda>x. P x \<and> Q x) xs = (todos P xs \<and> todos Q xs)"
  have "todos (\<lambda>x. P x \<and> Q x) (a # xs) =  ((P a \<and> Q a) \<and> (todos P xs \<and> todos Q xs))" using HI by simp
  also have "... = ((P a \<and> todos P xs) \<and> (Q a \<and> todos Q xs))" by blast
  also have "... = (todos P (a#xs) \<and> todos Q (a#xs)) " by simp
 finally show "todos (\<lambda>x. P x \<and> Q x) (a#xs) = (todos P (a#xs) \<and> todos Q (a#xs))" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 4.1. Demostrar o refutar automáticamente
     todos P (x @ y) = (todos P x \<and> todos P y)
  ---------------------------------------------------------------------
*}

lemma "todos P (x @ y) = (todos P x \<and> todos P y)"
by (induct x) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 4.2. Demostrar o refutar detalladamente
     todos P (x @ y) = (todos P x \<and> todos P y)
  ---------------------------------------------------------------------
*}

lemma todos_append: "todos P (x @ y) = (todos P x \<and> todos P y)"
proof (induct x)
  show "todos P ([] @ y) = (todos P [] \<and> todos P y)" by simp
next
  fix a x
  assume HI: "todos P (x @ y) = (todos P x \<and> todos P y)"
  have "todos P ((a#x) @ y) = (P a \<and> (todos P (x @ y)))" by simp
  also have "... = (P a \<and> (todos P x \<and> todos P y))" using HI by simp
  finally show "todos P ((a # x) @ y) = (todos P (a # x) \<and> todos P y)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 5.1. Demostrar o refutar automáticamente
     todos P (rev xs) = todos P xs
  ---------------------------------------------------------------------
*}

lemma "todos P (rev xs) = todos P xs"
apply (induct xs)
apply simp
apply (simp add: todos_append)
apply auto
done

text {*
  ---------------------------------------------------------------------
  Ejercicio 5.2. Demostrar o refutar detalladamente
     todos P (rev xs) = todos P xs
  ---------------------------------------------------------------------
*}

lemma "todos P (rev xs) = todos P xs"
proof (induct xs)
show "todos P (rev []) = todos P []" by simp
next
fix a xs
  assume HI: "todos P (rev xs) = todos P xs"
  have "todos P (rev (a # xs)) = (todos P ((rev xs)@[a]))" by simp
  also have "... = (todos P (rev xs) \<and> todos P [a])" by (simp add:todos_append)
  also have "... = (todos P xs \<and> P a)" using HI by simp
  also have "... = (P a \<and> todos P xs)" by arith
  also have "... = (todos P (a#xs))" by simp
  finally show "todos P (rev (a # xs)) = (todos P (a#xs))" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 6. Demostrar o refutar:
    algunos (\<lambda>x. P x \<and> Q x) xs = (algunos P xs \<and> algunos Q xs)
  ---------------------------------------------------------------------
*}

lemma "algunos (\<lambda>x. P x \<and> Q x) xs = (algunos P xs \<and> algunos Q xs)"
quickcheck
oops

text {*
  ---------------------------------------------------------------------
  Ejercicio 7.1. Demostrar o refutar automáticamente
     algunos P (map f xs) = algunos (P \<circ> f) xs
  ---------------------------------------------------------------------
*}

lemma "algunos P (map f xs) = algunos (P o f) xs"
apply (induct xs)
apply auto
done

text {*
  ---------------------------------------------------------------------
  Ejercicio 7.2. Demostrar o refutar datalladamente
     algunos P (map f xs) = algunos (P \<circ> f) xs
  ---------------------------------------------------------------------
*}

lemma "algunos P (map f xs) = algunos (P o f) xs"
proof (induct xs)
  show "algunos P (map f []) = algunos (P \<circ> f) []"  by simp
next
  fix a xs
  assume H1: "algunos P (map f xs) = algunos (P \<circ> f) xs"
  have  "algunos P (map f (a # xs)) = (algunos P (map f [a]) \<or> algunos P (map f xs))" by simp
  also have "\<dots> = (algunos (P \<circ> f) [a] \<or>  algunos (P \<circ> f) xs )" using H1 by simp
  also have "\<dots> = algunos (P \<circ> f) (a#xs)" by simp
  finally show "algunos P (map f (a # xs)) = algunos (P \<circ> f) (a#xs)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 8.1. Demostrar o refutar automáticamente
     algunos P (xs @ ys) = (algunos P xs \<or> algunos P ys)
  ---------------------------------------------------------------------
*}

lemma "algunos P (xs @ ys) = (algunos P xs \<or> algunos P ys)"
by (induct xs) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 8.2. Demostrar o refutar detalladamente
     algunos P (xs @ ys) = (algunos P xs \<or> algunos P ys)
  ---------------------------------------------------------------------
*}

lemma algunos_append: "algunos P (xs @ ys) = (algunos P xs \<or> algunos P ys)"
proof (induct xs)
  show "algunos P ([] @ ys) = (algunos P [] \<or> algunos P ys)" by simp
next
  fix a xs
  assume HI: "algunos P (xs @ ys) = (algunos P xs \<or> algunos P ys)"
  have "algunos P ((a # xs) @ ys) = (P a \<or> (algunos P (xs @ ys)))" by simp
  also have "... = (P a \<or> (algunos P xs \<or> algunos P ys))" using HI by simp
  finally show "algunos P ((a # xs) @ ys) = (algunos P (a # xs) \<or> algunos P ys)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 9.1. Demostrar o refutar automáticamente
     algunos P (rev xs) = algunos P xs
  ---------------------------------------------------------------------
*}

lemma "algunos P (rev xs) = algunos P xs"
apply (induct xs)
apply simp
apply (simp add: algunos_append)
apply auto
done

text {*
  ---------------------------------------------------------------------
  Ejercicio 9.2. Demostrar o refutar detalladamente
     algunos P (rev xs) = algunos P xs
  ---------------------------------------------------------------------
*}

lemma "algunos P (rev xs) = algunos P xs"
proof (induct xs)
  show "algunos P (rev []) = algunos P []" by simp
next
  fix a xs
  assume HI:"algunos P (rev xs) = algunos P xs"
  have "algunos P (rev (a # xs)) = algunos P ((rev xs) @ [a])" by simp
  also have "... = ((algunos P (rev xs)) \<or> (algunos P [a]))" by (simp add: algunos_append)
  also have "... = ((algunos P xs) \<or> (algunos P [a]))" using HI by simp
  also have "... = ((algunos P [a]) \<or> (algunos P xs))" by arith
  finally show "algunos P (rev (a # xs)) = algunos P (a # xs)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 10. Encontrar un término no trivial Z tal que sea cierta la
  siguiente ecuación:
     algunos (\<lambda>x. P x \<or> Q x) xs = Z
  y demostrar la equivalencia de forma automática y detallada.
  ---------------------------------------------------------------------
*}

lemma "algunos (\<lambda>x. P x \<or> Q x) xs = (algunos P xs \<or> algunos Q xs)"
by (induct xs) auto

lemma "algunos (\<lambda>x. P x \<or> Q x) xs = (algunos P xs \<or> algunos Q xs) "
proof (induct xs)
  show "algunos (\<lambda>x. P x \<or> Q x) [] = (algunos P [] \<or> algunos Q []) " by simp
next
  fix a xs
  assume HI: " algunos (\<lambda>x. P x \<or> Q x) xs = (algunos P xs \<or> algunos Q xs)"
  have " algunos (\<lambda>x. P x \<or> Q x) (a # xs) = ( P a \<or> Q a \<or> algunos (\<lambda>x. P x \<or> Q x) xs)" by simp
  also have "... = (P a \<or> Q a \<or> (algunos P xs \<or> algunos Q xs))" using HI by simp
  also have "\<dots> = (((P a) \<or> algunos P xs) \<or> ((Q a) \<or> algunos Q xs))" by arith
  also have "\<dots> = (algunos P (a#xs) \<or> algunos Q (a#xs))" by simp
  finally show "algunos (\<lambda>x. P x \<or> Q x) (a # xs) = (algunos P (a # xs) \<or> algunos Q (a # xs)) " by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 11.1. Demostrar o refutar automáticamente
     algunos P xs = (\<not> todos (\<lambda>x. (\<not> P x)) xs)
  ---------------------------------------------------------------------
*}

lemma "algunos P xs = (\<not> todos (\<lambda>x. (\<not> P x)) xs)"
by (induct xs) auto

text {*
  ---------------------------------------------------------------------
  Ejercicio 11.2. Demostrar o refutar datalladamente
     algunos P xs = (\<not> todos (\<lambda>x. (\<not> P x)) xs)
  ---------------------------------------------------------------------
*}

lemma "algunos P xs = (\<not> todos (\<lambda>x. (\<not> P x)) xs)"
proof (induct xs)
  show "algunos P [] = (\<not> todos (\<lambda>x. \<not> P x) [])" by simp
next
  fix a xs
  assume HI: "algunos P xs = (\<not> todos (\<lambda>x. \<not> P x) xs)"
  have "algunos P (a # xs) = (P a \<or> (algunos P xs))" by simp
  also have "... = (P a \<or> (\<not> todos (\<lambda>x. \<not> P x) xs))" using HI by simp
  finally show "algunos P (a # xs) = (\<not> todos (\<lambda>x. \<not> P x) (a # xs))" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 12. Definir la funcion primitiva recursiva
     estaEn :: 'a \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (estaEn x xs) se verifica si el elemento x está en la lista
  xs. Por ejemplo,
     estaEn (2::nat) [3,2,4] = True
     estaEn (1::nat) [3,2,4] = False
  ---------------------------------------------------------------------
*}

fun estaEn :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "estaEn x [] = False"
| "estaEn x (a#xs) = ((a = x) \<or> (estaEn x xs))"

text {*
  ---------------------------------------------------------------------
  Ejercicio 13. Expresar la relación existente entre estaEn y algunos.
  Demostrar dicha relación de forma automática y detallada.
  ---------------------------------------------------------------------
*}

lemma "estaEn a xs = algunos (\<lambda>x. x = a) xs"
by (induct xs) auto

lemma "estaEn x xs = (algunos (\<lambda>a. a=x) xs)"
proof (induct xs)
  show " estaEn x [] = algunos (\<lambda>a. a = x) []" by simp
next
  fix a xs
  assume HI: "estaEn x xs = algunos (\<lambda>a. a = x) xs"
  have "estaEn x (a # xs) = (a = x \<or> estaEn x xs)" by simp
  also have "... = (a = x \<or> algunos (\<lambda>a. a = x) xs)" using HI by simp
  finally show " estaEn x (a # xs) = algunos (\<lambda>a. a = x) (a # xs)" by simp
qed

end


section \<open>Basis Extension\<close>

text \<open>We prove that every linear indepent set/list of vectors can be extended into a basis.
  Similarly, from every set of vectors one can extract a linear independent set of vectors
  that spans the same space.\<close>

theory Basis_Extension
  imports
    LLL_Basis_Reduction.Gram_Schmidt_2
begin

context cof_vec_space
begin

lemma lin_indpt_list_length_le_n: assumes "lin_indpt_list xs"
  shows "length xs \<le> n"
proof -
  from assms[unfolded lin_indpt_list_def]
  have xs: "set xs \<subseteq> carrier_vec n" and dist: "distinct xs" and lin: "lin_indpt (set xs)" by auto
  from dist have "card (set xs) = length xs" by (rule distinct_card)
  moreover have "card (set xs) \<le> n"
    using lin xs dim_is_n li_le_dim(2) by auto
  ultimately show ?thesis by auto
qed

lemma lin_indpt_list_length_eq_n: assumes "lin_indpt_list xs"
  and "length xs = n"
shows "span (set xs) = carrier_vec n" "basis (set xs)"
proof -
  from assms[unfolded lin_indpt_list_def]
  have xs: "set xs \<subseteq> carrier_vec n" and dist: "distinct xs" and lin: "lin_indpt (set xs)" by auto
  from dist have "card (set xs) = length xs" by (rule distinct_card)
  with assms have "card (set xs) = n" by auto
  with lin xs show "span (set xs) = carrier_vec n" "basis (set xs)"  using dim_is_n
    by (metis basis_def dim_basis dim_li_is_basis fin_dim finite_basis_exists gen_ge_dim li_le_dim(1))+
qed

lemma expand_to_basis: assumes lin: "lin_indpt_list xs"
  shows "\<exists> ys. set ys \<subseteq> set (unit_vecs n) \<and> lin_indpt_list (xs @ ys) \<and> length (xs @ ys) = n"
proof -
  define y where "y = n - length xs"
  from lin have "length xs \<le> n" by (rule lin_indpt_list_length_le_n)
  hence "length xs + y = n" unfolding y_def by auto
  thus "\<exists> ys. set ys \<subseteq> set (unit_vecs n) \<and> lin_indpt_list (xs @ ys) \<and> length (xs @ ys) = n"
    using lin
  proof (induct y arbitrary: xs)
    case (0 xs)
    thus ?case by (intro exI[of _ Nil], auto)
  next
    case (Suc y xs)
    hence "length xs < n" by auto
    from Suc(3)[unfolded lin_indpt_list_def]
    have xs: "set xs \<subseteq> carrier_vec n" and dist: "distinct xs" and lin: "lin_indpt (set xs)" by auto
    from distinct_card[OF dist] Suc(2) have card: "card (set xs) < n" by auto
    have "span (set xs) \<noteq> carrier_vec n" using card dim_is_n xs basis_def dim_basis lin by auto
    with span_closed[OF xs] have "span (set xs) \<subset> carrier_vec n" by auto
    also have "carrier_vec n = span (set (unit_vecs n))"
      unfolding span_unit_vecs_is_carrier ..
    finally have sub: "span (set xs) \<subset> span (set (unit_vecs n))" .
    have "\<exists> u. u \<in> set (unit_vecs n) \<and> u \<notin> span (set xs)"
      using span_subsetI[OF xs, of "set (unit_vecs n)"] sub by force
    then obtain u where uu: "u \<in> set (unit_vecs n)" and usxs: "u \<notin> span (set xs)" by auto
    then have u: "u \<in> carrier_vec n" unfolding unit_vecs_def by auto
    let ?xs = "xs @ [u]"
    from span_mem[OF xs, of u] usxs have uxs: "u \<notin> set xs" by auto
    with dist have dist: "distinct ?xs" by auto
    have lin: "lin_indpt (set ?xs)" using lin_dep_iff_in_span[OF xs lin u uxs] usxs by auto
    from lin dist u xs have lin: "lin_indpt_list ?xs" unfolding lin_indpt_list_def by auto
    from Suc(2) have "length ?xs + y = n" by auto
    from Suc(1)[OF this lin] obtain ys where
      "set ys \<subseteq> set (unit_vecs n)" "lin_indpt_list (?xs @ ys)" "length (?xs @ ys) = n" by auto
    thus ?case using uu
      by (intro exI[of _ "u # ys"], auto)
  qed
qed

definition "basis_extension xs = (SOME ys.
  set ys \<subseteq> set (unit_vecs n) \<and> lin_indpt_list (xs @ ys) \<and> length (xs @ ys) = n)"

lemma basis_extension: assumes "lin_indpt_list xs"
  shows "set (basis_extension xs) \<subseteq> set (unit_vecs n)"
    "lin_indpt_list (xs @ basis_extension xs)"
    "length (xs @ basis_extension xs) = n"
  using someI_ex[OF expand_to_basis[OF assms], folded basis_extension_def] by auto

lemma exists_lin_indpt_sublist: assumes X: "X \<subseteq> carrier_vec n"
  shows "\<exists> Ls. lin_indpt_list Ls \<and> span (set Ls) = span X \<and> set Ls \<subseteq> X"
proof -
  let ?T = ?thesis
  have "(\<exists> Ls. lin_indpt_list Ls \<and> span (set Ls) \<subseteq> span X \<and> set Ls \<subseteq> X \<and> length Ls = k) \<or> ?T" for k
  proof (induct k)
    case 0
    have "lin_indpt {}" by (simp add: lindep_span)
    thus ?case using span_is_monotone by (auto simp: lin_indpt_list_def)
  next
    case (Suc k)
    show ?case
    proof (cases ?T)
      case False
      with Suc obtain Ls where lin: "lin_indpt_list Ls"
        and span: "span (set Ls) \<subseteq> span X" and Ls: "set Ls \<subseteq> X"  and len: "length Ls = k" by auto
      from Ls X have LsC: "set Ls \<subseteq> carrier_vec n" by auto
      show ?thesis
      proof (cases "X \<subseteq> span (set Ls)")
        case True
        hence "span X \<subseteq> span (set Ls)" using LsC X by (metis span_subsetI)
        with span have "span (set Ls) = span X" by auto
        hence ?T by (intro exI[of _ Ls] conjI True lin Ls)
        thus ?thesis by auto
      next
        case False
        with span obtain x where xX: "x \<in> X" and xSLs: "x \<notin> span (set Ls)" by auto
        from Ls X have LsC: "set Ls \<subseteq> carrier_vec n" by auto
        from span_mem[OF this, of x] xSLs have xLs: "x \<notin> set Ls" by auto
        let ?Ls = "x # Ls"
        show ?thesis
        proof (intro disjI1 exI[of _ ?Ls] conjI)
          show "length ?Ls = Suc k" using len by auto
          show "lin_indpt_list ?Ls" using lin xSLs xLs unfolding lin_indpt_list_def
            using lin_dep_iff_in_span[OF LsC _ _ xLs] xX X by auto
          show "set ?Ls \<subseteq> X" using xX Ls by auto
          from span_is_monotone[OF this]
          show "span (set ?Ls) \<subseteq> span X" .
        qed
      qed
    qed auto
  qed
  from this[of "n + 1"] lin_indpt_list_length_le_n show ?thesis by fastforce
qed

lemma exists_lin_indpt_subset: assumes "X \<subseteq> carrier_vec n"
  shows "\<exists> Ls. lin_indpt Ls \<and> span (Ls) = span X \<and> Ls \<subseteq> X"
proof -
  from exists_lin_indpt_sublist[OF assms]
  obtain Ls where "lin_indpt_list Ls \<and> span (set Ls) = span X \<and> set Ls \<subseteq> X" by auto
  thus ?thesis by (intro exI[of _ "set Ls"], auto simp: lin_indpt_list_def)
qed
end

end


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

  Expected shape of random Binary Search Trees
*)
section \<open>Expected shape of random Binary Search Trees\<close>
theory Random_BSTs
  imports
    Complex_Main
    "HOL-Probability.Random_Permutations"
    "HOL-Data_Structures.Tree_Set"
    Quick_Sort_Cost.Quick_Sort_Average_Case
begin

(* TODO: Hide this in the proper place *)
hide_const (open) Tree_Set.insert

subsection \<open>Auxiliary lemmas\<close>

(* TODO: Move? *)
lemma linorder_on_linorder_class [intro]:
  "linorder_on UNIV {(x, y). x \<le> (y :: 'a :: linorder)}"
  by (auto simp: linorder_on_def refl_on_def antisym_def trans_def total_on_def)

lemma Nil_in_permutations_of_set_iff [simp]: "[] \<in> permutations_of_set A \<longleftrightarrow> A = {}"
  by (auto simp: permutations_of_set_def)

lemma max_power_distrib_right:
  fixes a :: "'a :: linordered_semidom"
  shows "a > 1 \<Longrightarrow> max (a ^ b) (a ^ c) = a ^ max b c"
  by (auto simp: max_def)

lemma set_tree_empty_iff [simp]: "set_tree t = {} \<longleftrightarrow> t = Leaf"
  by (cases t) auto

lemma card_set_tree_bst: "bst t \<Longrightarrow> card (set_tree t) = size t"
proof (induction t)
  case (Node l x r)
  have "set_tree \<langle>l, x, r\<rangle> = insert x (set_tree l \<union> set_tree r)" by simp
  also from Node.prems have "card \<dots> = Suc (card (set_tree l \<union> set_tree r))"
    by (intro card_insert_disjoint) auto
  also from Node have "card (set_tree l \<union> set_tree r) = size l + size r"
    by (subst card_Un_disjoint) force+
  finally show ?case by simp
qed simp_all

lemma pair_pmf_cong:
  "p = p' \<Longrightarrow> q = q' \<Longrightarrow> pair_pmf p q = pair_pmf p' q'"
  by simp

lemma expectation_add_pair_pmf:
  fixes f :: "'a \<Rightarrow> 'c::{banach, second_countable_topology}"
  assumes "finite (set_pmf p)" and "finite (set_pmf q)"
  shows "measure_pmf.expectation (pair_pmf p q) (\<lambda>(x,y). f x + g y) =
           measure_pmf.expectation p f + measure_pmf.expectation q g"
proof -
  have "measure_pmf.expectation (pair_pmf p q) (\<lambda>(x,y). f x + g y) =
          measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z) + g (snd z))"
    by (simp add: case_prod_unfold)
  also have "\<dots> = measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z)) +
                  measure_pmf.expectation (pair_pmf p q) (\<lambda>z. g (snd z))"
    by (intro Bochner_Integration.integral_add integrable_measure_pmf_finite) (auto intro: assms)
  also have "measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z)) =
               measure_pmf.expectation (map_pmf fst (pair_pmf p q)) f" by simp
  also have "map_pmf fst (pair_pmf p q) = p" by (rule map_fst_pair_pmf)
  also have "measure_pmf.expectation (pair_pmf p q) (\<lambda>z. g (snd z)) =
               measure_pmf.expectation (map_pmf snd (pair_pmf p q)) g" by simp
  also have "map_pmf snd (pair_pmf p q) = q" by (rule map_snd_pair_pmf)
  finally show ?thesis .
qed

subsection \<open>Creating a BST from a list\<close>

text \<open>
  The following recursive function creates a binary search tree from a given list of
  elements by inserting them into an initially empty BST from left to right. We will prove
  that this is the case later, but the recursive definition has the advantage of giving us
  a useful induction rule, so we chose that definition and prove the alternative definitions later.

  This recursion, which already almost looks like QuickSort, will be key in analysing the
  shape distributions of random BSTs.
\<close>
fun bst_of_list :: "'a :: linorder list \<Rightarrow> 'a tree" where
  "bst_of_list [] = Leaf"
| "bst_of_list (x # xs) =
     Node (bst_of_list [y \<leftarrow> xs. y < x]) x (bst_of_list [y \<leftarrow> xs. y > x])"

lemma bst_of_list_eq_Leaf_iff [simp]: "bst_of_list xs = Leaf \<longleftrightarrow> xs = []"
  by (induction xs) auto

lemma bst_of_list_snoc [simp]:
  "bst_of_list (xs @ [y]) = Tree_Set.insert y (bst_of_list xs)"
  by (induction xs rule: bst_of_list.induct) auto

lemma bst_of_list_append:
  "bst_of_list (xs @ ys) = fold Tree_Set.insert ys (bst_of_list xs)"
proof (induction ys arbitrary: xs)
  case (Cons y ys)
  have "bst_of_list (xs @ (y # ys)) = bst_of_list ((xs @ [y]) @ ys)" by simp
  also have "\<dots> = fold Tree_Set.insert ys (bst_of_list (xs @ [y]))"
    by (rule Cons.IH)
  finally show ?case by simp
qed simp_all

text \<open>
  The following now shows that the recursive function indeed corresponds to the
  notion of inserting the elements from the list from left to right.
\<close>
lemma bst_of_list_altdef: "bst_of_list xs = fold Tree_Set.insert xs Leaf"
  using bst_of_list_append[of "[]" xs] by simp

lemma size_bst_insert: "x \<notin> set_tree t \<Longrightarrow> size (Tree_Set.insert x t) = Suc (size t)"
  by (induction t) auto

lemma set_bst_insert [simp]: "set_tree (Tree_Set.insert x t) = insert x (set_tree t)"
  by (induction t) auto

lemma set_bst_of_list [simp]: "set_tree (bst_of_list xs) = set xs"
  by (induction xs rule: rev_induct) simp_all

lemma size_bst_of_list_distinct [simp]:
  assumes "distinct xs"
  shows   "size (bst_of_list xs) = length xs"
  using assms by (induction xs rule: rev_induct) (auto simp: size_bst_insert)

lemma strict_mono_on_imp_less_iff:
  assumes "strict_mono_on f A" "x \<in> A" "y \<in> A"
  shows   "f x < (f y :: 'b :: linorder) \<longleftrightarrow> x < (y :: 'a :: linorder)"
  using assms by (cases x y rule: linorder_cases; force simp: strict_mono_on_def)+

lemma bst_of_list_map:
  fixes f :: "'a :: linorder \<Rightarrow> 'b :: linorder"
  assumes "strict_mono_on f A" "set xs \<subseteq> A"
  shows   "bst_of_list (map f xs) = map_tree f (bst_of_list xs)"
  using assms
proof (induction xs rule: bst_of_list.induct)
  case (2 x xs)
  have "[xa\<leftarrow>xs . f xa < f x] = [xa\<leftarrow>xs . xa < x]" and "[xa\<leftarrow>xs . f xa > f x] = [xa\<leftarrow>xs . xa > x]"
    using "2.prems" by (auto simp: strict_mono_on_imp_less_iff intro!: filter_cong)
  with 2 show ?case by (auto simp: filter_map o_def)
qed auto

subsection \<open>Random BSTs\<close>

text \<open>
  Analogously to the previous section, we can now view the concept of a random BST
  (i.\,e.\ a BST obtained by inserting a given set of elements in random order) in two
  different ways.

  We again start with the recursive variant:
\<close>
function random_bst :: "'a :: linorder set \<Rightarrow> 'a tree pmf" where
  "random_bst A =
     (if \<not>finite A \<or> A = {} then
        return_pmf Leaf
      else do {
        x \<leftarrow> pmf_of_set A;
        l \<leftarrow> random_bst {y \<in> A. y < x};
        r \<leftarrow> random_bst {y \<in> A. y > x};
        return_pmf (Node l x r)
     })"
  by auto
termination by (relation finite_psubset) auto

declare random_bst.simps [simp del]

lemma random_bst_empty [simp]: "random_bst {} = return_pmf Leaf"
  by (simp add: random_bst.simps)

lemma set_pmf_random_permutation [simp]:
  "finite A \<Longrightarrow> set_pmf (pmf_of_set (permutations_of_set A)) = {xs. distinct xs \<and> set xs = A}"
  by (subst set_pmf_of_set) (auto dest: permutations_of_setD)

text \<open>
  The alternative characterisation is the more intuitive one where we simply pick a
  random permutation of the set elements uniformly at random and insert them into an empty
  tree from left to right:
\<close>
lemma random_bst_altdef:
  assumes "finite A"
  shows   "random_bst A = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
using assms
proof (induction A rule: finite_psubset_induct)
  case (psubset A)
  define L R where "L = (\<lambda>x. {y\<in>A. y < x})" and "R = (\<lambda>x. {y\<in>A. y > x})"
  {
    fix x assume x: "x \<in> A"
    hence *: "L x \<subset> A" "R x \<subset> A" by (auto simp: L_def R_def)
    note this [THEN psubset.IH]
  } note IH = this

  show ?case
  proof (cases "A = {}")
    case False
    note A = \<open>finite A\<close> \<open>A \<noteq> {}\<close>
    have "random_bst A =
            do {
              x \<leftarrow> pmf_of_set A;
              (l, r) \<leftarrow> pair_pmf (random_bst (L x)) (random_bst (R x));
              return_pmf (Node l x r)
            }" using A unfolding pair_pmf_def L_def R_def
      by (subst random_bst.simps) (simp add: bind_return_pmf bind_assoc_pmf)
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      (l, r) \<leftarrow> pair_pmf
                        (map_pmf bst_of_list (pmf_of_set (permutations_of_set (L x))))
                        (map_pmf bst_of_list (pmf_of_set (permutations_of_set (R x))));
                      return_pmf (Node l x r)
                    }"
     using A by (intro bind_pmf_cong refl) (simp_all add: IH)
    also have "\<dots> = do {
                     x \<leftarrow> pmf_of_set A;
                     (ls, rs) \<leftarrow> pair_pmf (pmf_of_set (permutations_of_set (L x)))
                                          (pmf_of_set (permutations_of_set (R x)));
                     return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
                   }" unfolding map_pair [symmetric]
      by (simp add: map_pmf_def case_prod_unfold bind_return_pmf bind_assoc_pmf)
    also have "L = (\<lambda>x. {y \<in> A - {x}. y \<le> x})" by (auto simp: L_def)
    also have "R = (\<lambda>x. {y \<in> A - {x}. \<not>y \<le> x})" by (auto simp: R_def)
    also have "do {
                 x \<leftarrow> pmf_of_set A;
                 (ls, rs) \<leftarrow> pair_pmf (pmf_of_set (permutations_of_set {y \<in> A - {x}. y \<le> x}))
                                      (pmf_of_set (permutations_of_set {y \<in> A - {x}. \<not>y \<le> x}));
                 return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
               } =
               do {
                 x \<leftarrow> pmf_of_set A;
                 (ls, rs) \<leftarrow> map_pmf (partition (\<lambda>y. y \<le> x))
                               (pmf_of_set (permutations_of_set (A - {x})));
                 return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
               }" using \<open>finite A\<close>
      by (intro bind_pmf_cong refl partition_random_permutations [symmetric]) auto
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      (ls, rs) \<leftarrow> map_pmf (\<lambda>xs. ([y\<leftarrow>xs. y < x], [y\<leftarrow>xs. y > x]))
                                    (pmf_of_set (permutations_of_set (A - {x})));
                      return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
                    }" using A
      by (intro bind_pmf_cong refl map_pmf_cong)
         (auto intro!: filter_cong dest: permutations_of_setD simp: order.strict_iff_order)
    also have "\<dots> = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
      using A by (subst random_permutation_of_set[of A])
                 (auto simp: map_pmf_def bind_return_pmf o_def bind_assoc_pmf not_le)
    finally show ?thesis .
  qed (simp_all add: pmf_of_set_singleton)
qed

lemma finite_set_random_bst [simp, intro]:
  "finite A \<Longrightarrow> finite (set_pmf (random_bst A))"
  by (simp add: random_bst_altdef)

lemma random_bst_code [code]:
  "random_bst (set xs) = map_pmf bst_of_list (pmf_of_set (permutations_of_set (set xs)))"
  by (rule random_bst_altdef) simp_all

lemma random_bst_singleton [simp]: "random_bst {x} = return_pmf (Node Leaf x Leaf)"
  by (simp add: random_bst_altdef pmf_of_set_singleton)

lemma size_random_bst:
  assumes "t \<in> set_pmf (random_bst A)" "finite A"
  shows   "size t = card A"
proof -
  from assms obtain xs where "distinct xs" "A = set xs" "t = bst_of_list xs"
    by (auto simp: random_bst_altdef dest: permutations_of_setD)
  thus ?thesis using \<open>finite A\<close> by (simp add: distinct_card)
qed

lemma random_bst_image:
  assumes "finite A" "strict_mono_on f A"
  shows   "random_bst (f ` A) = map_pmf (map_tree f) (random_bst A)"
proof -
  from assms(2) have inj: "inj_on f A" by (rule strict_mono_on_imp_inj_on)
  with assms have "inj_on (map f) (permutations_of_set A)"
    by (intro inj_on_mapI) auto
  with assms inj have "random_bst (f ` A) =
                         map_pmf (\<lambda>x. bst_of_list (map f x)) (pmf_of_set (permutations_of_set A))"
    by (simp add: random_bst_altdef permutations_of_set_image_inj map_pmf_of_set_inj [symmetric]
                  pmf.map_comp o_def)
  also have "\<dots> = map_pmf (map_tree f) (random_bst A)"
    unfolding random_bst_altdef[OF \<open>finite A\<close>] pmf.map_comp o_def using assms
    by (intro map_pmf_cong refl bst_of_list_map[of f A]) (auto dest: permutations_of_setD)
  finally show ?thesis .
qed

text \<open>
  We can also re-phrase the non-recursive definition using the @{const fold_random_permutation}
  combinator from the HOL-Probability library, which folds over a given set in random order.
\<close>
lemma random_bst_altdef':
  assumes "finite A"
  shows   "random_bst A = fold_random_permutation Tree_Set.insert Leaf A"
proof -
  have "random_bst A = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
    using assms by (simp add: random_bst_altdef)
  also have "\<dots> = map_pmf (\<lambda>xs. fold Tree_Set.insert xs Leaf) (pmf_of_set (permutations_of_set A))"
    using assms by (intro map_pmf_cong refl) (auto simp: bst_of_list_altdef)
  also from assms have "\<dots> = fold_random_permutation Tree_Set.insert Leaf A"
    by (simp add: fold_random_permutation_fold)
  finally show ?thesis .
qed

subsection \<open>Expected height\<close>

text \<open>
  For the purposes of the analysis of the expected height, we define the following notion
  of `expected height', which is essentially two to the power of the height (as defined
  by Cormen \textit{et al.}) with a special treatment for the empty tree, which has exponential
  height 0.

  Note that the height defined by Cormen \textit{et al.}\ differs from the @{const height}
  function here in Isabelle in that for them, the height of the empty tree is undefined and
  the height of a singleton tree is 0 etc., whereas in Isabelle, the height of the empty tree is
  0 and the height of a singleton tree is 1.
\<close>
definition eheight :: "'a tree \<Rightarrow> nat" where
  "eheight t = (if t = Leaf then 0 else 2 ^ (height t - 1))"

lemma eheight_Leaf [simp]: "eheight Leaf = 0"
  by (simp add: eheight_def)

lemma eheight_Node_singleton [simp]: "eheight (Node Leaf x Leaf) = 1"
  by (simp add: eheight_def)

lemma eheight_Node:
  "l \<noteq> Leaf \<or> r \<noteq> Leaf \<Longrightarrow> eheight (Node l x r) = 2 * max (eheight l) (eheight r)"
  by (cases l; cases r) (simp_all add: eheight_def max_power_distrib_right)

fun eheight_rbst :: "nat \<Rightarrow> nat pmf" where
  "eheight_rbst 0 = return_pmf 0"
| "eheight_rbst (Suc 0) = return_pmf 1"
| "eheight_rbst (Suc n) =
     do {
       k \<leftarrow> pmf_of_set {..n};
       h1 \<leftarrow> eheight_rbst k;
       h2 \<leftarrow> eheight_rbst (n - k);
       return_pmf (2 * max h1 h2)}"

definition eheight_exp :: "nat \<Rightarrow> real" where
  "eheight_exp n = measure_pmf.expectation (eheight_rbst n) real"

lemma eheight_rbst_reduce:
  assumes "n > 1"
  shows   "eheight_rbst n =
             do {k \<leftarrow> pmf_of_set {..<n}; h1 \<leftarrow> eheight_rbst k; h2 \<leftarrow> eheight_rbst (n - k - 1);
                 return_pmf (2 * max h1 h2)}"
  using assms by (cases n rule: eheight_rbst.cases) (simp_all add: lessThan_Suc_atMost)

lemma Leaf_in_set_random_bst_iff:
  assumes "finite A"
  shows   "Leaf \<in> set_pmf (random_bst A) \<longleftrightarrow> A = {}"
proof
  assume "Leaf \<in> set_pmf (random_bst A)"
  from size_random_bst[OF this] and assms show "A = {}" by auto
qed auto

    hence "map_pmf eheight (random_bst A) =
             do {
               x \<leftarrow> pmf_of_set A;
               l \<leftarrow> random_bst {y \<in> A. y < x};
               r \<leftarrow> random_bst {y \<in> A. y > x};
               return_pmf (eheight (Node l x r))
             }"
      using \<open>finite A\<close> by (subst random_bst.simps) (auto simp: map_bind_pmf)
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      l \<leftarrow> random_bst {y \<in> A. y < x};
                      r \<leftarrow> random_bst {y \<in> A. y > x};
                      return_pmf (2 * max (eheight l) (eheight r))
                    }"
      using 3 \<open>finite A\<close> exists_other
      by (intro bind_pmf_cong refl, subst eheight_Node)
         (force simp: Leaf_in_set_random_bst_iff not_less nonempty eheight_Node)+
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      h1 \<leftarrow> map_pmf eheight (random_bst {y \<in> A. y < x});
                      h2 \<leftarrow> map_pmf eheight (random_bst {y \<in> A. y > x});
                      return_pmf (2 * max h1 h2)
                    }"
      by (simp add: bind_map_pmf)
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      h1 \<leftarrow> eheight_rbst (card {y \<in> A. y < x});
                      h2 \<leftarrow> eheight_rbst (card {y \<in> A. y > x});
                      return_pmf (2 * max h1 h2)
                    }"
      using \<open>A \<noteq> {}\<close> \<open>finite A\<close> by (intro bind_pmf_cong psubset.IH [symmetric] refl) auto
    also have "\<dots> = do {
                      k \<leftarrow> map_pmf rank (pmf_of_set A);
                      h1 \<leftarrow> eheight_rbst k;
                      h2 \<leftarrow> eheight_rbst (card A - k - 1);
                      return_pmf (2 * max h1 h2)
                    }"
      unfolding bind_map_pmf
    proof (intro bind_pmf_cong refl, goal_cases)
      case (1 x)
      have "rank x = card {y\<in>A-{x}. y \<le> x}" by (simp add: rank_def linorder_rank_def)
      also have "{y\<in>A-{x}. y \<le> x} = {y\<in>A. y < x}" by auto
      finally show ?case by simp
    next
      case (2 x)
      have "A - {x} = {y\<in>A-{x}. y \<le> x} \<union> {y\<in>A. y > x}" by auto
      also have "card \<dots> = rank x + card {y\<in>A. y > x}"
        using \<open>finite A\<close> by (subst card_Un_disjoint) (auto simp: rank_def linorder_rank_def)
      finally have "card {y\<in>A. y > x} = card A - rank x - 1"
        using 2 \<open>finite A\<close> \<open>A \<noteq> {}\<close> by simp
      thus ?case by simp
    qed
    also have "map_pmf rank (pmf_of_set A) = pmf_of_set {..<card A}"
      using \<open>A \<noteq> {}\<close> \<open>finite A\<close> unfolding rank_def
      by (intro map_pmf_of_set_bij_betw bij_betw_linorder_rank[of UNIV]) auto
    also have "do {
                 k \<leftarrow> pmf_of_set {..<card A};
                 h1 \<leftarrow> eheight_rbst k;
                 h2 \<leftarrow> eheight_rbst (card A - k - 1);
                 return_pmf (2 * max h1 h2)
               } = eheight_rbst (card A)"
      by (rule eheight_rbst_reduce [symmetric]) fact+
    finally show ?thesis ..
  qed (auto simp: is_singleton_def)
qed

lemma finite_pmf_set_eheight_rbst [simp, intro]: "finite (set_pmf (eheight_rbst n))"
proof -
  have "eheight_rbst n = map_pmf eheight (random_bst {..<n})"
    by (subst eheight_rbst [symmetric]) auto
  also have "finite (set_pmf \<dots>)" by simp
  finally show ?thesis .
qed

lemma eheight_exp_1 [simp]: "eheight_exp (Suc 0) = 1"
  by (simp add: eheight_exp_def lessThan_Suc)

lemma eheight_exp_reduce_bound:
  assumes "n > 1"
  shows   "eheight_exp n \<le> 4 / n * (\<Sum>k<n. eheight_exp k)"
proof -
  have [simp]: "real (max a b) = max (real a) (real b)" for a b
    by (simp add: max_def)
  let ?f = "\<lambda>(h1,h2). max h1 h2"
  let ?p = "\<lambda>k. pair_pmf (eheight_rbst k) (eheight_rbst (n - Suc k))"
  have "eheight_exp n = measure_pmf.expectation (eheight_rbst n) real"
    by (simp add: eheight_exp_def)
  also have "\<dots> = 1 / real n * (\<Sum>k<n. measure_pmf.expectation
                                         (map_pmf (\<lambda>(h1,h2). 2 * max h1 h2) (?p k)) real)"
    (is "_ = _ * ?S") unfolding pair_pmf_def map_bind_pmf
    by (subst eheight_rbst_reduce [OF assms], subst pmf_expectation_bind_pmf_of_set)
       (insert assms, auto simp: sum_divide_distrib divide_simps)
  also have "?S = (\<Sum>k<n. measure_pmf.expectation (map_pmf (\<lambda>x. 2 * x) (map_pmf ?f (?p k))) real)"
    by (simp only: pmf.map_comp o_def case_prod_unfold)
  also have "\<dots> = 2 * (\<Sum>k<n. measure_pmf.expectation (map_pmf ?f (?p k)) real)" (is "_ = _ * ?S'")
    by (subst integral_map_pmf) (simp add: sum_distrib_left)
  also have "?S' = (\<Sum>k<n. measure_pmf.expectation (?p k) (\<lambda>(h1,h2). max (real h1) (real h2)))"
    by (simp add: case_prod_unfold)
  also have "\<dots> \<le> (\<Sum>k<n. measure_pmf.expectation (?p k) (\<lambda>(h1,h2). real h1 + real h2))"
    unfolding integral_map_pmf case_prod_unfold
    by (intro sum_mono Bochner_Integration.integral_mono integrable_measure_pmf_finite) auto
  also have "\<dots> = (\<Sum>k<n. eheight_exp k) + (\<Sum>k<n. eheight_exp (n - Suc k))"
    by (subst expectation_add_pair_pmf) (auto simp: sum.distrib eheight_exp_def)
  also have "(\<Sum>k<n. eheight_exp (n - Suc k)) = (\<Sum>k<n. eheight_exp k)"
    by (intro sum.reindex_bij_witness[of _ "\<lambda>k. n - Suc k" "\<lambda>k. n - Suc k"]) auto
  also have "1 / real n * (2 * (\<dots> + \<dots>)) = 4 / real n * \<dots>" by simp
  finally show ?thesis using assms by (simp_all add: mult_left_mono divide_right_mono)
qed

text \<open>
  We now define the following upper bound on the expected exponential height due to
  Cormen\ \textit{et\ al.}~\cite{cormen}:
\<close>
lemma eheight_exp_bound: "eheight_exp n \<le> real ((n + 3) choose 3) / 4"
proof (induction n rule: less_induct)
  case (less n)
  consider "n = 0" | "n = 1" | "n > 1" by force
  thus ?case
  proof cases
    case 3
    hence "eheight_exp n \<le> 4 / n * (\<Sum>k<n. eheight_exp k)"
      by (rule eheight_exp_reduce_bound)
    also have "(\<Sum>k<n. eheight_exp k) \<le> (\<Sum>k<n. real ((k + 3) choose 3) / 4)"
      by (intro sum_mono less.IH) auto
    also have "\<dots> = real (\<Sum>k<n. ((k + 3) choose 3)) / 4"
      by (simp add: sum_divide_distrib)
    also have "(\<Sum>k<n. ((k + 3) choose 3)) = (\<Sum>k\<le>n - 1. ((k + 3) choose 3))"
      using \<open>n > 1\<close> by (intro sum.cong) auto
    also have "\<dots> = ((n + 3) choose 4)"
      using choose_rising_sum(1)[of 3 "n - 1"] and \<open>n > 1\<close> by (simp add: add_ac Suc3_eq_add_3)
    also have "4 / real n * (\<dots> / 4) = real ((n + 3) choose 3) / 4" using \<open>n > 1\<close>
      by (cases n) (simp_all add: binomial_fact fact_numeral divide_simps)
    finally show ?thesis using \<open>n > 1\<close> by (simp add: mult_left_mono divide_right_mono)
  qed (auto simp: eval_nat_numeral)
qed

text \<open>
  We then show that this is indeed an upper bound on the expected exponential height by induction
  over the set of elements. This proof mostly follows that by Cormen\ \textit{et al.}~\cite{cormen},
  and partially an answer on the Computer Science Stack Exchange~\cite{sofl}.
\<close>

text \<open>
  Since the function $\uplambda x.\ 2 ^ x$ is convex, we can then easily derive a bound on the
  actual height using Jensen's inequality:
\<close>
definition height_exp_approx :: "nat \<Rightarrow> real" where
  "height_exp_approx n = log 2 (real ((n + 3) choose 3) / 4) + 1"

theorem height_expectation_bound:
  assumes "finite A" "A \<noteq> {}"
  shows   "measure_pmf.expectation (random_bst A) height
             \<le> height_exp_approx (card A)"
proof -
  have "convex_on UNIV ((powr) 2)"
    by (intro convex_on_realI[where f' = "\<lambda>x. ln 2 * 2 powr x"])
       (auto intro!: derivative_eq_intros DERIV_powr simp: powr_def [abs_def])
  hence "2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t - 1)) \<le>
          measure_pmf.expectation (random_bst A) (\<lambda>t. 2 powr real (height t - 1))"
    using assms
    by (intro measure_pmf.jensens_inequality[where I = UNIV])
       (auto intro!: integrable_measure_pmf_finite)
  also have "(\<lambda>t. 2 powr real (height t - 1)) = (\<lambda>t. 2 ^ (height t - 1))"
    by (simp add: powr_realpow)
  also have "measure_pmf.expectation (random_bst A) (\<lambda>t. 2 ^ (height t - 1)) =
               measure_pmf.expectation (random_bst A) (\<lambda>t. real (eheight t))"
    using assms
    by (intro integral_cong_AE)
       (auto simp: AE_measure_pmf_iff random_bst_altdef eheight_def)
  also have "\<dots> = measure_pmf.expectation (map_pmf eheight (random_bst A)) real"
    by simp
  also have "map_pmf eheight (random_bst A) = eheight_rbst (card A)"
    by (rule eheight_rbst [symmetric]) fact+
  also have "measure_pmf.expectation \<dots> real = eheight_exp (card A)"
    by (simp add: eheight_exp_def)
  also have "\<dots> \<le> real ((card A + 3) choose 3) / 4" by (rule eheight_exp_bound)
  also have "measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t - 1)) =
               measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)"
  proof (intro integral_cong_AE AE_pmfI, goal_cases)
    case (3 t)
    with \<open>A \<noteq> {}\<close> and assms show ?case
      by (subst of_nat_diff) (auto simp: Suc_le_eq random_bst_altdef)
  qed auto
  finally have "2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)
                  \<le> real ((card A + 3) choose 3) / 4" .
  hence "log 2 (2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)) \<le>
           log 2 (real ((card A + 3) choose 3) / 4)" (is "?lhs \<le> ?rhs")
    by (subst log_le_cancel_iff) (auto simp: )
  also have "?lhs = measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)"
    by simp
  also have "\<dots> = measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t)) - 1"
    using assms
    by (subst Bochner_Integration.integral_diff) (auto intro!: integrable_measure_pmf_finite)
  finally show ?thesis by (simp add: height_exp_approx_def)
qed

text \<open>
  This upper bound is asymptotically equivalent to $c \ln n$ with
  $c = \frac{3}{\ln 2} \approx 4.328$. This is actually a relatively tight upper bound, since
  the exact asymptotics of the expected height of a random BST is $c \ln n$ with
  $c \approx 4.311$.~\cite{reed} However, the proof of these precise asymptotics is very intricate
  and we will therefore be content with the upper bound.

  In particular, we can now show that the expected height is $O(\log n)$.
\<close>
lemma ln_sum_bigo_ln: "(\<lambda>x::real. ln (x + c)) \<in> O(ln)"
proof (rule bigoI_tendsto)
  from eventually_gt_at_top[of "1::real"] show "eventually (\<lambda>x::real. ln x \<noteq> 0) at_top"
    by eventually_elim simp_all
next
  show "((\<lambda>x. ln (x + c) / ln x) \<longlongrightarrow> 1) at_top"
  proof (rule lhospital_at_top_at_top)
    show "eventually (\<lambda>x. ((\<lambda>x. ln (x + c)) has_real_derivative inverse (x + c)) (at x)) at_top"
      using eventually_gt_at_top[of "-c"]
      by eventually_elim (auto intro!: derivative_eq_intros simp: field_simps)
    show "eventually (\<lambda>x. ((\<lambda>x. ln x) has_real_derivative inverse x) (at x)) at_top"
      using eventually_gt_at_top[of 0]
      by eventually_elim (auto intro!: derivative_eq_intros simp: field_simps)
    show "((\<lambda>x. inverse (x + c) / inverse x) \<longlongrightarrow> 1) at_top"
    proof (rule Lim_transform_eventually)
      show "eventually (\<lambda>x. inverse (1 + c / x) = inverse (x + c) / inverse x) at_top"
        using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "-c"]
        by eventually_elim (simp add: field_simps)
      have "((\<lambda>x. inverse (1 + c / x)) \<longlongrightarrow> inverse (1 + 0)) at_top"
        by (intro tendsto_inverse tendsto_add tendsto_const
              real_tendsto_divide_at_top[OF tendsto_const] filterlim_ident) simp_all
      thus "((\<lambda>x. inverse (1 + c / x)) \<longlongrightarrow> 1) at_top" by simp
    qed
  qed (auto simp: ln_at_top eventually_at_top_not_equal)
qed

corollary height_expectation_bigo: "height_exp_approx \<in> O(ln)"
proof -
  let ?T = "\<lambda>x::real. log 2 (x + 1) + log 2 (x + 2) + log 2 (x + 3) + (1 - log 2 24)"
  have "eventually (\<lambda>n. height_exp_approx n =
          log 2 (real n + 1) + log 2 (real n + 2) + log 2 (real n + 3) + (1 - log 2 24)) at_top"
    (is "eventually (\<lambda>n. _ = ?T n) at_top") using eventually_gt_at_top[of "0::nat"]
  proof eventually_elim
    case (elim n)
    have "height_exp_approx n = log 2 (real (n + 3 choose 3) / 4) + 1"
      by (simp add: height_exp_approx_def log_divide)
    also have "real ((n + 3) choose 3) = real (n + 3) gchoose 3"
      by (simp add: binomial_gbinomial)
    also have "\<dots> / 4 = (real n + 1) * (real n + 2) * (real n + 3) / 24"
      by (simp add: gbinomial_pochhammer' numeral_3_eq_3 pochhammer_Suc add_ac)
    also have "log 2 \<dots> = log 2 (real n + 1) + log 2 (real n + 2) + log 2 (real n + 3) - log 2 24"
      by (simp add: log_divide log_mult)
    finally show ?case by simp
  qed
  hence "height_exp_approx \<in> \<Theta>(?T)" by (rule bigthetaI_cong)
  also have *: "(\<lambda>x. ln (x + c) / ln 2) \<in> O(ln)" for c :: real
    by (subst landau_o.big.cdiv_in_iff') (auto intro!: ln_sum_bigo_ln)
  have "?T \<in> O(\<lambda>n. ln (real n))" unfolding log_def
    by (intro bigo_real_nat_transfer sum_in_bigo ln_sum_bigo_ln *) simp_all
  finally show ?thesis .
qed

subsection \<open>Lookup costs\<close>

text \<open>
  The following function describes the cost incurred when looking up a specific element
  in a specific BST. The cost corresponds to the number of edges traversed in the lookup.
\<close>

primrec lookup_cost :: "'a :: linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
  "lookup_cost x Leaf = 0"
| "lookup_cost x (Node l y r) =
     (if x = y then 0
      else if x < y then Suc (lookup_cost x l)
      else Suc (lookup_cost x r))"

text \<open>
  Some of the literature defines these costs as 1 in the case that the current node is
  the correct one, i.\,e.\ their costs are our costs plus 1. These alternative costs are
  exactly the number of comparisons performed in the lookup. Our cost function has the
  advantage of precisely summing up to the internal path length and therefore gives us
  slightly nicer results, and since the difference is only a ${}+1$ in the end, this
  variant seemed more reasonable.
\<close>

text \<open>
  It can be shown with a simple induction that The sum of all lookup costs in a tree is the
  internal path length of the tree.
\<close>
theorem sum_lookup_costs:
  fixes t :: "'a :: linorder tree"
  assumes "bst t"
  shows   "(\<Sum>x\<in>set_tree t. lookup_cost x t) = ipl t"
using assms
proof (induction t)
  case (Node l x r)
  from Node.prems
    have disj: "x \<notin> set_tree l" "x \<notin> set_tree r" "set_tree l \<inter> set_tree r = {}" by force+
  have "set_tree (Node l x r) = insert x (set_tree l \<union> set_tree r)" by simp
  also have "(\<Sum>y\<in>\<dots>. lookup_cost y (Node l x r)) = lookup_cost x \<langle>l, x, r\<rangle> +
               (\<Sum>y\<in>set_tree l. lookup_cost y \<langle>l, x, r\<rangle>) + (\<Sum>y\<in>set_tree r. lookup_cost y \<langle>l, x, r\<rangle>)"
    using disj by (simp add: sum.union_disjoint)
  also have "(\<Sum>y\<in>set_tree l. lookup_cost y \<langle>l, x, r\<rangle>) = (\<Sum>y\<in>set_tree l. 1 + lookup_cost y l)"
    using disj and Node by (intro sum.cong refl) auto
  also have "\<dots> = size l + ipl l" using Node
    by (subst sum.distrib) (simp_all add: card_set_tree_bst)
  also have "(\<Sum>y\<in>set_tree r. lookup_cost y \<langle>l, x, r\<rangle>) = (\<Sum>y\<in>set_tree r. 1 + lookup_cost y r)"
    using disj and Node by (intro sum.cong refl) auto
  also have "\<dots> = size r + ipl r" using Node
    by (subst sum.distrib) (simp_all add: card_set_tree_bst)
  finally show ?case by simp
qed simp_all

text \<open>
  This allows us to easily show that the expected cost of looking up a random element in a
  fixed tree is the internal path length divided by the number of elements.
\<close>
theorem expected_lookup_cost:
  assumes "bst t" "t \<noteq> Leaf"
  shows   "measure_pmf.expectation (pmf_of_set (set_tree t)) (\<lambda>x. lookup_cost x t) =
             ipl t / size t"
  using assms by (subst integral_pmf_of_set)
                 (simp_all add: sum_lookup_costs of_nat_sum [symmetric] card_set_tree_bst)

text \<open>
  Therefore, we will now turn to analysing the internal path length of a random BST. This
  then clearly related to the expected lookup costs of a random element in a random BST by
  the above result.
\<close>

subsection \<open>Average Path Length\<close>

text \<open>
  The internal path length satisfies the recursive equation @{thm ipl.simps(2)[of l x r]}.
  This is quite similar to the number of comparisons performed by QuickSort, and indeed, we can
  reduce the internal path length of a random BST to the number of comparisons performed by
  QuickSort on a randomly-ordered list relatively easily:
\<close>
theorem map_pmf_random_bst_eq_rqs_cost:
  assumes "finite A"
  shows   "map_pmf ipl (random_bst A) = rqs_cost (card A)"
using assms
proof (induction A rule: finite_psubset_induct)
  case (psubset A)
  show ?case
  proof (cases "A = {}")
    case False
    note A = \<open>finite A\<close> \<open>A \<noteq> {}\<close>
    define n where "n = card A - 1"
    define rank :: "'a \<Rightarrow> nat" where "rank = linorder_rank {(x,y). x \<le> y} A"
    from A have card: "card A = Suc n" by (cases "card A") (auto simp: n_def)
    from A have "map_pmf ipl (random_bst A) =
                   do {
                     x \<leftarrow> pmf_of_set A;
                     (l,r) \<leftarrow> pair_pmf (random_bst {y \<in> A. y < x}) (random_bst {y \<in> A. y > x});
                     return_pmf (ipl (Node l x r))
                   }"
      by (subst random_bst.simps)
         (simp_all add: pair_pmf_def card map_pmf_def bind_assoc_pmf bind_return_pmf)
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      (l,r) \<leftarrow> pair_pmf (random_bst {y \<in> A. y < x}) (random_bst {y \<in> A. y > x});
                      return_pmf (n + ipl l + ipl r)
                    }"
    proof (intro bind_pmf_cong refl, clarify, goal_cases)
      case (1 x l r)
      from 1 and A have "n = card (A - {x})" by (simp add: n_def)
      also have "A - {x} = {y\<in>A. y < x} \<union> {y\<in>A. y > x}" by auto
      also have "card \<dots> = card {y\<in>A. y < x} + card {y\<in>A. y > x}"
        using \<open>finite A\<close> by (intro card_Un_disjoint) auto
      also from 1 and A have "card {y\<in>A. y < x} = size l" by (auto dest: size_random_bst)
      also from 1 and A have "card {y\<in>A. y > x} = size r" by (auto dest: size_random_bst)
      finally show ?case by simp
    qed
    also have "\<dots> = do {
                      x \<leftarrow> pmf_of_set A;
                      (l,r) \<leftarrow> pair_pmf (map_pmf ipl (random_bst {y \<in> A. y < x}))
                                        (map_pmf ipl (random_bst {y \<in> A. y > x}));
                      return_pmf (n + l + r)
                    }" by (simp add: map_pair [symmetric] case_prod_unfold bind_map_pmf)
    also have "\<dots> = do {
                      i \<leftarrow> map_pmf rank (pmf_of_set A);
                      (l,r) \<leftarrow> pair_pmf (rqs_cost i) (rqs_cost (n - i));
                      return_pmf (n + l + r)
                    }" (is "_ = bind_pmf _ ?f") unfolding bind_map_pmf
    proof (intro bind_pmf_cong refl pair_pmf_cong, goal_cases)
      case (1 x)
      have "map_pmf ipl (random_bst {y \<in> A. y < x}) = rqs_cost (card {y \<in> A. y < x})"
        using 1 and A by (intro psubset.IH) auto
      also have "{y \<in> A. y < x} = {y \<in> A - {x}. y \<le> x}" by auto
      hence "card {y \<in> A. y < x} = rank x" by (simp add: rank_def linorder_rank_def)
      finally show ?case .
    next
      case (2 x)
      have "map_pmf ipl (random_bst {y \<in> A. y > x}) = rqs_cost (card {y \<in> A. y > x})"
        using 2 and A by (intro psubset.IH) auto
      also have "{y \<in> A. y > x} = A - {x} - {y \<in> A - {x}. y \<le> x}" by auto
      hence "card {y \<in> A. y > x} = card \<dots>" by (simp only:)
      also from 2 and A have "\<dots> = n - rank x"
        by (subst card_Diff_subset) (auto simp: rank_def linorder_rank_def n_def)
      finally show ?case .
    qed
    also from A have "map_pmf rank (pmf_of_set A) = pmf_of_set {..<card A}"
      unfolding rank_def by (intro map_pmf_of_set_bij_betw bij_betw_linorder_rank[of UNIV]) auto
    also have "{..<card A} = {..n}" by (auto simp: card)
    also have "pmf_of_set \<dots> \<bind> ?f = rqs_cost (card A)"
      by (simp add: pair_pmf_def bind_assoc_pmf bind_return_pmf card)
    finally show ?thesis .
  qed simp_all
qed

text \<open>
  In particular, this means that the expected values are the same:
\<close>
corollary expected_ipl_random_bst_eq:
  assumes "finite A"
  shows   "measure_pmf.expectation (random_bst A) ipl = rqs_cost_exp (card A)"
proof -
  have "measure_pmf.expectation (random_bst A) ipl =
          measure_pmf.expectation (map_pmf ipl (random_bst A)) real" by simp
  also from assms have "map_pmf ipl (random_bst A) = rqs_cost (card A)"
    by (rule map_pmf_random_bst_eq_rqs_cost)
  also have "measure_pmf.expectation \<dots> real = rqs_cost_exp (card A)"
    by (rule expectation_rqs_cost)
  finally show ?thesis .
qed

text \<open>
  Therefore, the results about the expected number of comparisons of QuickSort carry over
  to the expected internal path length:
\<close>
corollary expected_ipl_random_bst_eq':
  assumes "finite A"
  shows   "measure_pmf.expectation (random_bst A) ipl =
             2 * real (card A + 1) * harm (card A) - 4 * real (card A)"
  by (simp add: expected_ipl_random_bst_eq rqs_cost_exp_eq assms)

end